[bpt/emacs.git] / lisp / gnus / gnus-html.el

;;; gnus-html.el --- Render HTML in a buffer.

;; Copyright (C) 2010  Free Software Foundation, Inc.

;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: html, web

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; The idea is to provide a simple, fast and pretty minimal way to
;; render HTML (including links and images) in a buffer, based on an
;; external HTML renderer (i.e., w3m).

;;; Code:

(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)
(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."
  :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"
  :group 'gnus-art
  :type 'integer)

(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,
and Emacs supports it, then the images will be rescaled down to
fit these criteria."
  :version "24.1"
  :group 'gnus-art
  :type 'float)

(defvar gnus-html-image-map
  (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)))))

(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 (&optional handle)
  (let ((article-buffer (current-buffer)))
    (unless handle
      (setq handle (mm-dissect-buffer t)))
    (save-restriction
      (narrow-to-region (point) (point))
      (save-excursion
	(mm-with-part handle
	  (let* ((coding-system-for-read 'utf-8)
		 (coding-system-for-write 'utf-8)
		 (default-process-coding-system
		   (cons coding-system-for-read coding-system-for-write))
		 (charset (mail-content-type-get (mm-handle-type handle)
						 'charset)))
	    (when (and charset
		       (setq charset (mm-charset-to-coding-system charset))
		       (not (eq charset 'ascii)))
	      (insert (prog1
			  (mm-decode-coding-string (buffer-string) charset)
			(erase-buffer)
			(mm-enable-multibyte))))
	    (call-process-region (point-min) (point-max)
				 "w3m"
				 nil article-buffer nil
				 "-halfdump"
				 "-no-cookie"
				 "-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)
				 "-o" "display_image=on"
				 "-T" "text/html"))))
      (gnus-html-wash-tags))))

(defvar gnus-article-mouse-face)

(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)
    (goto-char (point-min))
    ;; 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
                            (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 (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\\)=\"\\([^\"]+\\)"
                                              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)
	    start (match-beginning 0))
      (when (> (length parameters) 0)
	(set-text-properties 0 (1- (length parameters)) nil parameters))
      (delete-region start (point))
      (when (search-forward (concat "</" tag ">") nil t)
	(delete-region (match-beginning 0) (match-end 0)))
      (setq end (point))
      (cond
       ;; Fetch and insert a picture.
       ((equal tag "img_alt"))
       ;; Add a link.
       ((or (equal tag "a")
	    (equal tag "A"))
	(when (string-match "href=\"\\([^\"]+\\)" parameters)
	  (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 (mm-url-decode-entities-string url)
				   url)
	  (let ((overlay (gnus-make-overlay start end)))
	    (gnus-overlay-put overlay 'evaporate t)
	    (gnus-overlay-put overlay 'gnus-button-url url)
	    (gnus-put-text-property start end 'gnus-string url)
	    (when gnus-article-mouse-face
	      (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face)))))
       ;; The upper-case IMG_ALT is apparently just an artifact that
       ;; should be deleted.
       ((equal tag "IMG_ALT")
	(delete-region start end))
       ;; w3m does not normalize the case
       ((or (equal tag "b")
            (equal tag "B"))
        (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-bold))
       ((or (equal tag "u")
            (equal tag "U"))
        (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-underline))
       ((or (equal tag "i")
            (equal tag "I"))
        (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-italic))
       ((or (equal tag "s")
            (equal tag "S"))
        (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-strikethru))
       ((or (equal tag "ins")
            (equal tag "INS"))
        (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-underline))
       ;; Handle different UL types
       ((equal tag "_SYMBOL")
        (when (string-match "TYPE=\\(.+\\)" parameters)
          (let ((type (string-to-number (match-string 1 parameters))))
            (delete-region start end)
            (cond ((= type 33) (insert " "))
                  ((= type 34) (insert " "))
                  ((= type 35) (insert " "))
                  ((= type 36) (insert " "))
                  ((= type 37) (insert " "))
                  ((= type 38) (insert " "))
                  ((= type 39) (insert " "))
                  ((= type 40) (insert " "))
                  ((= type 42) (insert " "))
                  ((= type 43) (insert " "))
                  (t (insert " "))))))
       ;; Whatever.  Just ignore the tag.
       (t
	))
      (goto-char start))
    (goto-char (point-min))
    ;; The output from -halfdump isn't totally regular, so strip
    ;; off any </pre_int>s that were left over.
    (while (re-search-forward "</pre_int>\\|</internal>" nil t)
      (replace-match "" t t))
    (mm-url-decode-entities)))

(defun gnus-html-insert-image ()
  "Fetch and insert the image under point."
  (interactive)
  (apply 'gnus-html-display-image (get-text-property (point) 'gnus-image)))

(defun gnus-html-show-alt-text ()
  "Show the ALT text of the image under point."
  (interactive)
  (message "%s" (get-text-property (point) 'gnus-alt-text)))

(defun gnus-html-browse-image ()
  "Browse the image under point."
  (interactive)
  (browse-url (get-text-property (point) 'gnus-image-url)))

(defun gnus-html-browse-url ()
  "Browse the image under point."
  (interactive)
  (let ((url (get-text-property (point) 'gnus-string)))
    (if (not url)
	(message "No URL at point")
      (browse-url url))))

(defun gnus-html-schedule-image-fetching (buffer image)
  "Retrieve IMAGE, and place it into BUFFER on arrival."
  (gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, image %s"
                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."
  (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)
  "Get image data for URL.
Return a string with image data."
  (with-temp-buffer
    (mm-disable-multibyte)
    (url-cache-extract (url-cache-create-filename url))
    (when (or (search-forward "\n\n" nil t)
              (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))
           (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-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)
                    (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-image-url-blocked-p (url blocked-images)
  "Find out if URL is blocked by BLOCKED-IMAGES."
  (let ((ret (and blocked-images
                  (string-match blocked-images url))))
    (if ret
        (gnus-message 8 "gnus-html-image-url-blocked-p: %s blocked by regex %s"
                      url blocked-images)
      (gnus-message 9 "gnus-html-image-url-blocked-p: %s passes regex %s"
                    url blocked-images))
    ret))

(defun gnus-html-show-images ()
  "Show any images that are in the HTML-rendered article buffer.
This only works if the article in question is HTML."
  (interactive)
  (gnus-with-article-buffer
    (dolist (overlay (overlays-in (point-min) (point-max)))
      (let ((o (overlay-get overlay 'gnus-image)))
        (when o
          (apply 'gnus-html-display-image o))))))

;;;###autoload
(defun gnus-html-prefetch-images (summary)
  (when (buffer-live-p summary)
    (let ((blocked-images (with-current-buffer summary
                            gnus-blocked-images)))
      (save-match-data
	(while (re-search-forward "<img[^>]+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)
                (gnus-html-schedule-image-fetching nil
                                                   (list url))))))))))

(provide 'gnus-html)

;;; gnus-html.el ends here
Commit	Line	Data
7426b4f7	1	;;; gnus-html.el --- Render HTML in a buffer.
655efd71 KY	2
	3	;; Copyright (C) 2010 Free Software Foundation, Inc.
	4
	5	;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
	6	;; Keywords: html, web
	7
	8	;; This file is part of GNU Emacs.
	9
	10	;; GNU Emacs is free software: you can redistribute it and/or modify
	11	;; it under the terms of the GNU General Public License as published by
	12	;; the Free Software Foundation, either version 3 of the License, or
	13	;; (at your option) any later version.
	14
	15	;; GNU Emacs is distributed in the hope that it will be useful,
	16	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	17	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	18	;; GNU General Public License for more details.
	19
	20	;; You should have received a copy of the GNU General Public License
	21	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
	22
	23	;;; Commentary:
	24
	25	;; The idea is to provide a simple, fast and pretty minimal way to
	26	;; render HTML (including links and images) in a buffer, based on an
	27	;; external HTML renderer (i.e., w3m).
	28
	29	;;; Code:
	30
2d217ead SM	31	(eval-when-compile (require 'cl))
2d217ead SM	32	(eval-when-compile (require 'mm-decode))
eca7d7bf RF	33
eca7d7bf RF	34	(require 'gnus-art)
14721afc	35	(require 'mm-url)
286c4fc2	36	(require 'url)
2c8b2fc8	37	(require 'url-cache)
b4e64499	38	(require 'xml)
b069e5a6	39	(require 'browse-url)
9c619400	40	(eval-and-compile (unless (featurep 'xemacs) (require 'help-fns)))
14721afc	41
2c8b2fc8	42	(defcustom gnus-html-image-cache-ttl (days-to-time 7)
b069e5a6	43	"Time used to determine if we should use images from the cache."
b0e30310	44	:version "24.1"
b1992461 KY	45	:group 'gnus-art
	46	:type 'integer)
	47
b069e5a6 G	48	(defcustom gnus-html-image-automatic-caching t
	49	"Whether automatically cache retrieve images."
	50	:version "24.1"
	51	:group 'gnus-art
	52	:type 'boolean)
	53
b1992461 KY	54	(defcustom gnus-html-frame-width 70
b1992461 KY	55	"What width to use when rendering HTML."
b0e30310	56	:version "24.1"
b1992461 KY	57	:group 'gnus-art
	58	:type 'integer)
	59
239952b0	60	(defcustom gnus-max-image-proportion 0.9
7d7520b9 LMI	61	"How big pictures displayed are in relation to the window they're in.
	62	A value of 0.7 means that they are allowed to take up 70% of the
	63	width and height of the window. If they are larger than this,
	64	and Emacs supports it, then the images will be rescaled down to
	65	fit these criteria."
	66	:version "24.1"
	67	:group 'gnus-art
	68	:type 'float)
	69
10e91ca9 LMI	70	(defvar gnus-html-image-map
	71	(let ((map (make-sparse-keymap)))
	72	(define-key map "u" 'gnus-article-copy-string)
	73	(define-key map "i" 'gnus-html-insert-image)
2c8b2fc8	74	(define-key map "v" 'gnus-html-browse-url)
10e91ca9 LMI	75	map))
10e91ca9 LMI	76
99fcd180 LMI	77	(defvar gnus-html-displayed-image-map
	78	(let ((map (make-sparse-keymap)))
	79	(define-key map "a" 'gnus-html-show-alt-text)
	80	(define-key map "i" 'gnus-html-browse-image)
9778a07a LMI	81	(define-key map "\r" 'gnus-html-browse-url)
	82	(define-key map "u" 'gnus-article-copy-string)
	83	(define-key map [tab] 'widget-forward)
99fcd180 LMI	84	map))
99fcd180 LMI	85
d3361e62 KY	86	(eval-and-compile
	87	(defalias 'gnus-html-encode-url-chars
	88	(if (fboundp 'browse-url-url-encode-chars)
	89	'browse-url-url-encode-chars
	90	(lambda (text chars)
	91	"URL-encode the chars in TEXT that match CHARS.
	92	CHARS is a regexp-like character alternative (e.g., \"[)$]\")."
	93	(let ((encoded-text (copy-sequence text))
	94	(s 0))
	95	(while (setq s (string-match chars encoded-text s))
	96	(setq encoded-text
	97	(replace-match (format "%%%x"
	98	(string-to-char
	99	(match-string 0 encoded-text)))
	100	t t encoded-text)
	101	s (1+ s)))
a41c2e6d	102	encoded-text)))))
d3361e62	103
b069e5a6 G	104	(defun gnus-html-encode-url (url)
b069e5a6 G	105	"Encode URL."
d3361e62	106	(gnus-html-encode-url-chars url "[)$ ]"))
b069e5a6	107
2c8b2fc8 JD	108	(defun gnus-html-cache-expired (url ttl)
	109	"Check if URL is cached for more than TTL."
	110	(cond (url-standalone-mode
	111	(not (file-exists-p (url-cache-create-filename url))))
	112	(t (let ((cache-time (url-is-cached url)))
	113	(if cache-time
	114	(time-less-p
	115	(time-add
	116	cache-time
	117	ttl)
	118	(current-time))
	119	t)))))
	120
655efd71	121	;;;###autoload
29cd986b	122	(defun gnus-article-html (&optional handle)
655efd71	123	(let ((article-buffer (current-buffer)))
29cd986b LMI	124	(unless handle
29cd986b LMI	125	(setq handle (mm-dissect-buffer t)))
655efd71 KY	126	(save-restriction
	127	(narrow-to-region (point) (point))
	128	(save-excursion
b1992461 KY	129	(mm-with-part handle
	130	(let* ((coding-system-for-read 'utf-8)
	131	(coding-system-for-write 'utf-8)
	132	(default-process-coding-system
da43765d KY	133	(cons coding-system-for-read coding-system-for-write))
	134	(charset (mail-content-type-get (mm-handle-type handle)
	135	'charset)))
	136	(when (and charset
	137	(setq charset (mm-charset-to-coding-system charset))
	138	(not (eq charset 'ascii)))
60893e6f KY	139	(insert (prog1
	140	(mm-decode-coding-string (buffer-string) charset)
	141	(erase-buffer)
	142	(mm-enable-multibyte))))
b1992461	143	(call-process-region (point-min) (point-max)
c9fc72fa	144	"w3m"
b1992461 KY	145	nil article-buffer nil
	146	"-halfdump"
	147	"-no-cookie"
379dde03	148	"-I" "UTF-8"
b1992461 KY	149	"-O" "UTF-8"
b1992461 KY	150	"-o" "ext_halfdump=1"
bdaa75c7	151	"-o" "display_ins_del=2"
379dde03	152	"-o" "pre_conv=1"
b1992461 KY	153	"-t" (format "%s" tab-width)
b1992461 KY	154	"-cols" (format "%s" gnus-html-frame-width)
a93b858c	155	"-o" "display_image=on"
b1992461	156	"-T" "text/html"))))
655efd71 KY	157	(gnus-html-wash-tags))))
655efd71 KY	158
2d217ead SM	159	(defvar gnus-article-mouse-face)
2d217ead SM	160
9778a07a LMI	161	(defun gnus-html-pre-wash ()
	162	(goto-char (point-min))
	163	(while (re-search-forward " <pre_int> </pre_int> *\n" nil t)
	164	(replace-match "" t t))
	165	(goto-char (point-min))
	166	(while (re-search-forward "<a name[^\n>]+>" nil t)
	167	(replace-match "" t t)))
	168
698ecd82	169	(defun gnus-html-wash-images ()
2c8b2fc8	170	"Run through current buffer and replace img tags by images."
ad142133	171	(let (tag parameters string start end images url)
655efd71	172	(goto-char (point-min))
9778a07a LMI	173	;; Search for all the images first.
	174	(while (re-search-forward "<img_alt \\([^>]*\\)>" nil t)
	175	(setq parameters (match-string 1)
	176	start (match-beginning 0))
	177	(delete-region start (point))
	178	(when (search-forward "</img_alt>" (line-end-position) t)
	179	(delete-region (match-beginning 0) (match-end 0)))
	180	(setq end (point))
	181	(when (string-match "src=\"\\([^\"]+\\)" parameters)
b069e5a6	182	(setq url (gnus-html-encode-url (match-string 1 parameters)))
9778a07a LMI	183	(gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url)
	184	(if (string-match "^cid:\\(.*\\)" url)
	185	;; URLs with cid: have their content stashed in other
	186	;; parts of the MIME structure, so just insert them
	187	;; immediately.
6f7e2ffd JD	188	(let* ((handle (mm-get-content-id
	189	(setq url (match-string 1 url))))
	190	(image (when handle
	191	(gnus-create-image (mm-with-part handle (buffer-string))
	192	nil t))))
9778a07a	193	(when image
2c8b2fc8 JD	194	(let ((string (buffer-substring start end)))
2c8b2fc8 JD	195	(delete-region start end)
6f7e2ffd JD	196	(gnus-put-image (gnus-rescale-image image (gnus-html-maximum-image-size))
6f7e2ffd JD	197	(gnus-string-or string "*") 'cid)
2c8b2fc8	198	(gnus-add-image 'cid image))))
9778a07a	199	;; Normal, external URL.
2c8b2fc8 JD	200	(let ((alt-text (when (string-match "\\(alt\\\|title\\)=\"\\([^\"]+\\)"
2c8b2fc8 JD	201	parameters)
b4e64499	202	(xml-substitute-special (match-string 2 parameters)))))
b069e5a6	203	(gnus-put-text-property start end 'gnus-image-url url)
2c8b2fc8 JD	204	(if (gnus-html-image-url-blocked-p
	205	url
	206	(if (buffer-live-p gnus-summary-buffer)
	207	(with-current-buffer gnus-summary-buffer
	208	gnus-blocked-images)
	209	gnus-blocked-images))
	210	(progn
	211	(widget-convert-button
	212	'link start end
	213	:action 'gnus-html-insert-image
	214	:help-echo url
	215	:keymap gnus-html-image-map
	216	:button-keymap gnus-html-image-map)
	217	(let ((overlay (gnus-make-overlay start end))
4478e074	218	(spec (list url start end alt-text)))
2c8b2fc8 JD	219	(gnus-overlay-put overlay 'local-map gnus-html-image-map)
2c8b2fc8 JD	220	(gnus-overlay-put overlay 'gnus-image spec)
2c8b2fc8 JD	221	(gnus-put-text-property
	222	start end
	223	'gnus-image spec)))
	224	;; Non-blocked url
	225	(let ((width
	226	(when (string-match "width=\"?\\([0-9]+\\)" parameters)
	227	(string-to-number (match-string 1 parameters))))
	228	(height
	229	(when (string-match "height=\"?\\([0-9]+\\)" parameters)
	230	(string-to-number (match-string 1 parameters)))))
	231	;; Don't fetch images that are really small. They're
	232	;; probably tracking pictures.
	233	(when (and (or (null height)
	234	(> height 4))
	235	(or (null width)
	236	(> width 4)))
	237	(gnus-html-display-image url start end alt-text))))))))))
	238
	239	(defun gnus-html-display-image (url start end alt-text)
	240	"Display image at URL on text from START to END.
	241	Use ALT-TEXT for the image string."
	242	(if (gnus-html-cache-expired url gnus-html-image-cache-ttl)
	243	;; We don't have it, so schedule it for fetching
	244	;; asynchronously.
	245	(gnus-html-schedule-image-fetching
	246	(current-buffer)
b069e5a6	247	(list url alt-text))
2c8b2fc8	248	;; It's already cached, so just insert it.
b069e5a6	249	(gnus-html-put-image (gnus-html-get-image-data url) url alt-text)))
698ecd82 LMI	250
	251	(defun gnus-html-wash-tags ()
	252	(let (tag parameters string start end images url)
	253	(gnus-html-pre-wash)
	254	(gnus-html-wash-images)
9778a07a	255
f39ccb2e	256	(goto-char (point-min))
9778a07a	257	;; Then do the other tags.
b1992461	258	(while (re-search-forward "<\\([^ />]+\\)\\([^>]*\\)>" nil t)
655efd71 KY	259	(setq tag (match-string 1)
655efd71 KY	260	parameters (match-string 2)
b1992461	261	start (match-beginning 0))
d99a4591	262	(when (> (length parameters) 0)
b1992461 KY	263	(set-text-properties 0 (1- (length parameters)) nil parameters))
b1992461 KY	264	(delete-region start (point))
698ecd82	265	(when (search-forward (concat "</" tag ">") nil t)
b1992461 KY	266	(delete-region (match-beginning 0) (match-end 0)))
b1992461 KY	267	(setq end (point))
655efd71 KY	268	(cond
655efd71 KY	269	;; Fetch and insert a picture.
9778a07a	270	((equal tag "img_alt"))
655efd71	271	;; Add a link.
c6c81576 LMI	272	((or (equal tag "a")
c6c81576 LMI	273	(equal tag "A"))
655efd71	274	(when (string-match "href=\"\\([^\"]+\\)" parameters)
ad142133	275	(setq url (match-string 1 parameters))
2aafbe5a	276	(gnus-message 8 "gnus-html-wash-tags: fetching link URL %s" url)
655efd71	277	(gnus-article-add-button start end
562f5ce5	278	'browse-url (mm-url-decode-entities-string url)
ad142133	279	url)
655efd71 KY	280	(let ((overlay (gnus-make-overlay start end)))
655efd71 KY	281	(gnus-overlay-put overlay 'evaporate t)
ad142133	282	(gnus-overlay-put overlay 'gnus-button-url url)
10e91ca9	283	(gnus-put-text-property start end 'gnus-string url)
655efd71 KY	284	(when gnus-article-mouse-face
655efd71 KY	285	(gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face)))))
fe01e1a3 LMI	286	;; The upper-case IMG_ALT is apparently just an artifact that
	287	;; should be deleted.
	288	((equal tag "IMG_ALT")
	289	(delete-region start end))
bdaa75c7 LMI	290	;; w3m does not normalize the case
	291	((or (equal tag "b")
	292	(equal tag "B"))
	293	(gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-bold))
	294	((or (equal tag "u")
	295	(equal tag "U"))
	296	(gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-underline))
	297	((or (equal tag "i")
	298	(equal tag "I"))
	299	(gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-italic))
	300	((or (equal tag "s")
	301	(equal tag "S"))
	302	(gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-strikethru))
	303	((or (equal tag "ins")
	304	(equal tag "INS"))
	305	(gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-underline))
	306	;; Handle different UL types
	307	((equal tag "_SYMBOL")
	308	(when (string-match "TYPE=\\(.+\\)" parameters)
	309	(let ((type (string-to-number (match-string 1 parameters))))
	310	(delete-region start end)
	311	(cond ((= type 33) (insert " "))
	312	((= type 34) (insert " "))
	313	((= type 35) (insert " "))
	314	((= type 36) (insert " "))
	315	((= type 37) (insert " "))
	316	((= type 38) (insert " "))
	317	((= type 39) (insert " "))
	318	((= type 40) (insert " "))
	319	((= type 42) (insert " "))
	320	((= type 43) (insert " "))
	321	(t (insert " "))))))
655efd71 KY	322	;; Whatever. Just ignore the tag.
655efd71 KY	323	(t
b1992461 KY	324	))
	325	(goto-char start))
	326	(goto-char (point-min))
	327	;; The output from -halfdump isn't totally regular, so strip
	328	;; off any </pre_int>s that were left over.
f9e50677	329	(while (re-search-forward "</pre_int>\\\|</internal>" nil t)
b1992461	330	(replace-match "" t t))
74d8321d	331	(mm-url-decode-entities)))
b1992461	332
10e91ca9 LMI	333	(defun gnus-html-insert-image ()
	334	"Fetch and insert the image under point."
	335	(interactive)
2c8b2fc8	336	(apply 'gnus-html-display-image (get-text-property (point) 'gnus-image)))
10e91ca9	337
99fcd180 LMI	338	(defun gnus-html-show-alt-text ()
	339	"Show the ALT text of the image under point."
	340	(interactive)
	341	(message "%s" (get-text-property (point) 'gnus-alt-text)))
	342
	343	(defun gnus-html-browse-image ()
	344	"Browse the image under point."
	345	(interactive)
2c8b2fc8	346	(browse-url (get-text-property (point) 'gnus-image-url)))
99fcd180	347
9778a07a LMI	348	(defun gnus-html-browse-url ()
	349	"Browse the image under point."
	350	(interactive)
	351	(let ((url (get-text-property (point) 'gnus-string)))
	352	(if (not url)
	353	(message "No URL at point")
	354	(browse-url url))))
	355
2c8b2fc8 JD	356	(defun gnus-html-schedule-image-fetching (buffer image)
	357	"Retrieve IMAGE, and place it into BUFFER on arrival."
	358	(gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, image %s"
	359	buffer image)
367f7f81 LMI	360	(let ((args (list (car image)
	361	'gnus-html-image-fetched
	362	(list buffer image))))
9c619400	363	(when (> (length (if (featurep 'xemacs)
814cc274	364	(cdr (split-string (function-arglist 'url-retrieve)))
9c619400 KY	365	(help-function-arglist 'url-retrieve)))
9c619400 KY	366	4)
367f7f81	367	(setq args (nconc args (list t))))
130e977f LMI	368	(ignore-errors
130e977f LMI	369	(apply #'url-retrieve args))))
b1992461	370
286c4fc2	371	(defun gnus-html-image-fetched (status buffer image)
b069e5a6 G	372	"Callback function called when image has been fetched."
	373	(unless (plist-get status :error)
	374	(when gnus-html-image-automatic-caching
	375	(url-store-in-cache (current-buffer)))
	376	(when (and (or (search-forward "\n\n" nil t)
	377	(search-forward "\r\n\r\n" nil t))
	378	(buffer-live-p buffer))
	379	(let ((data (buffer-substring (point) (point-max))))
	380	(with-current-buffer buffer
	381	(let ((inhibit-read-only t))
	382	(gnus-html-put-image data (car image) (cadr image)))))))
2c8b2fc8 JD	383	(kill-buffer (current-buffer)))
	384
	385	(defun gnus-html-get-image-data (url)
	386	"Get image data for URL.
	387	Return a string with image data."
	388	(with-temp-buffer
	389	(mm-disable-multibyte)
	390	(url-cache-extract (url-cache-create-filename url))
b069e5a6 G	391	(when (or (search-forward "\n\n" nil t)
b069e5a6 G	392	(search-forward "\r\n\r\n" nil t))
2c8b2fc8 JD	393	(buffer-substring (point) (point-max)))))
2c8b2fc8 JD	394
6f7e2ffd JD	395	(defun gnus-html-maximum-image-size ()
	396	"Return the maximum size of an image according to `gnus-max-image-proportion'."
	397	(let ((edges (gnus-window-inside-pixel-edges
	398	(get-buffer-window (current-buffer)))))
	399	;; (width . height)
	400	(cons
	401	;; Aimed width
	402	(truncate
	403	(* gnus-max-image-proportion
	404	(- (nth 2 edges) (nth 0 edges))))
	405	;; Aimed height
	406	(truncate (* gnus-max-image-proportion
	407	(- (nth 3 edges) (nth 1 edges)))))))
	408
b069e5a6	409	(defun gnus-html-put-image (data url &optional alt-text)
6f7e2ffd	410	"Put an image with DATA from URL and optional ALT-TEXT."
73137971	411	(when (gnus-graphic-display-p)
870409d4 G	412	(let* ((start (text-property-any (point-min) (point-max)
870409d4 G	413	'gnus-image-url url))
b069e5a6 G	414	(end (when start
	415	(next-single-property-change start 'gnus-image-url))))
	416	;; Image found?
	417	(when start
	418	(let* ((image
	419	(ignore-errors
	420	(gnus-create-image data nil t)))
	421	(size (and image
	422	(if (featurep 'xemacs)
	423	(cons (glyph-width image) (glyph-height image))
	424	(image-size image t)))))
	425	(save-excursion
	426	(goto-char start)
870409d4 G	427	(let ((alt-text (or alt-text
870409d4 G	428	(buffer-substring-no-properties start end))))
b069e5a6 G	429	(if (and image
	430	;; Kludge to avoid displaying 30x30 gif images, which
	431	;; seems to be a signal of a broken image.
	432	(not (and (if (featurep 'xemacs)
	433	(glyphp image)
	434	(listp image))
	435	(eq (if (featurep 'xemacs)
870409d4 G	436	(let ((d (cdadar
	437	(specifier-spec-list
	438	(glyph-image image)))))
b069e5a6 G	439	(and (vectorp d)
	440	(aref d 0)))
	441	(plist-get (cdr image) :type))
	442	'gif)
	443	(= (car size) 30)
	444	(= (cdr size) 30))))
	445	;; Good image, add it!
6f7e2ffd	446	(let ((image (gnus-rescale-image image (gnus-html-maximum-image-size))))
b069e5a6 G	447	(delete-region start end)
	448	(gnus-put-image image alt-text 'external)
	449	(gnus-put-text-property start (point) 'help-echo alt-text)
870409d4 G	450	(gnus-overlay-put
	451	(gnus-make-overlay start (point)) 'local-map
	452	gnus-html-displayed-image-map)
	453	(gnus-put-text-property start (point)
	454	'gnus-alt-text alt-text)
b069e5a6	455	(when url
870409d4 G	456	(gnus-put-text-property start (point)
870409d4 G	457	'gnus-image-url url))
b069e5a6 G	458	(gnus-add-image 'external image)
	459	t)
	460	;; Bad image, try to show something else
	461	(when (fboundp 'find-image)
	462	(delete-region start end)
870409d4 G	463	(setq image (find-image
870409d4 G	464	'((:type xpm :file "lock-broken.xpm"))))
b069e5a6 G	465	(gnus-put-image image alt-text 'internal)
	466	(gnus-add-image 'internal image))
	467	nil))))))))
2c8b2fc8	468
c6c81576	469	(defun gnus-html-image-url-blocked-p (url blocked-images)
99fcd180	470	"Find out if URL is blocked by BLOCKED-IMAGES."
c6c81576 LMI	471	(let ((ret (and blocked-images
c6c81576 LMI	472	(string-match blocked-images url))))
2aafbe5a TZ	473	(if ret
	474	(gnus-message 8 "gnus-html-image-url-blocked-p: %s blocked by regex %s"
	475	url blocked-images)
	476	(gnus-message 9 "gnus-html-image-url-blocked-p: %s passes regex %s"
	477	url blocked-images))
d743e0d1 TZ	478	ret))
d743e0d1 TZ	479
25f28806 LMI	480	(defun gnus-html-show-images ()
	481	"Show any images that are in the HTML-rendered article buffer.
	482	This only works if the article in question is HTML."
	483	(interactive)
	484	(gnus-with-article-buffer
2c8b2fc8 JD	485	(dolist (overlay (overlays-in (point-min) (point-max)))
	486	(let ((o (overlay-get overlay 'gnus-image)))
	487	(when o
	488	(apply 'gnus-html-display-image o))))))
25f28806	489
b1992461 KY	490	;;;###autoload
b1992461 KY	491	(defun gnus-html-prefetch-images (summary)
bdaa75c7 LMI	492	(when (buffer-live-p summary)
	493	(let ((blocked-images (with-current-buffer summary
	494	gnus-blocked-images)))
b1992461	495	(save-match-data
0a887f39	496	(while (re-search-forward "<img[^>]+src=[\"']\\([^\"']+\\)" nil t)
b069e5a6	497	(let ((url (gnus-html-encode-url (match-string 1))))
c6c81576	498	(unless (gnus-html-image-url-blocked-p url blocked-images)
2c8b2fc8 JD	499	(when (gnus-html-cache-expired url gnus-html-image-cache-ttl)
	500	(gnus-html-schedule-image-fetching nil
	501	(list url))))))))))
b1992461 KY	502
b1992461 KY	503	(provide 'gnus-html)
655efd71 KY	504
655efd71 KY	505	;;; gnus-html.el ends here