[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)

(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-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
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))

(defun gnus-html-encode-url (url)
  "Encode URL."
  (browse-url-url-encode-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
		(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 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 (plusp (length parameters))
	(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 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)
  (ignore-errors
    (url-retrieve (car image)
                  'gnus-html-image-fetched
                  (list buffer image))))

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