X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fshr.el;h=423679afe5170607349d008339aaff412a5097c4;hp=2e7968e8deea566f5f99f700cce1fb3557aa6cd7;hb=0cd494a72be81805c59bbda60fe270f649eadd28;hpb=2e80acc3d5080e2a714404546a367e95b0ac738e diff --git a/lisp/shr.el b/lisp/shr.el index 2e7968e8d..423679afe 100644 --- a/lisp/shr.el +++ b/lisp/shr.el @@ -1,6 +1,6 @@ ;;; shr.el --- Simple HTML Renderer -;; Copyright (C) 2010-2011 Free Software Foundation, Inc. +;; Copyright (C) 2010-2012 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: html @@ -35,6 +35,7 @@ (defgroup shr nil "Simple HTML Renderer" + :version "24.1" :group 'mail) (defcustom shr-max-image-proportion 0.9 @@ -53,17 +54,17 @@ fit these criteria." :group 'shr :type 'regexp) -(defcustom shr-table-horizontal-line ? +(defcustom shr-table-horizontal-line ?\s "Character used to draw horizontal table lines." :group 'shr :type 'character) -(defcustom shr-table-vertical-line ? +(defcustom shr-table-vertical-line ?\s "Character used to draw vertical table lines." :group 'shr :type 'character) -(defcustom shr-table-corner ? +(defcustom shr-table-corner ?\s "Character used to draw table corners." :group 'shr :type 'character) @@ -87,6 +88,9 @@ used." This is used for cid: URLs, and the function is called with the cid: URL as the argument.") +(defvar shr-put-image-function 'shr-put-image + "Function called to put image and alt string.") + (defface shr-strike-through '((t (:strike-through t))) "Font for elements." :group 'shr) @@ -109,11 +113,13 @@ cid: URL as the argument.") (defvar shr-table-depth 0) (defvar shr-stylesheet nil) (defvar shr-base nil) +(defvar shr-ignore-cache nil) (defvar shr-map (let ((map (make-sparse-keymap))) (define-key map "a" 'shr-show-alt-text) (define-key map "i" 'shr-browse-image) + (define-key map "z" 'shr-zoom-image) (define-key map "I" 'shr-insert-image) (define-key map "u" 'shr-copy-url) (define-key map "v" 'shr-browse-url) @@ -124,22 +130,42 @@ cid: URL as the argument.") ;; Public functions and commands. (defun shr-visit-file (file) + "Parse FILE as an HTML document, and render it in a new buffer." (interactive "fHTML file name: ") (pop-to-buffer "*html*") (erase-buffer) (shr-insert-document (with-temp-buffer (insert-file-contents file) - (libxml-parse-html-region (point-min) (point-max))))) + (libxml-parse-html-region (point-min) (point-max)))) + (goto-char (point-min))) ;;;###autoload (defun shr-insert-document (dom) + "Render the parsed document DOM into the current buffer. +DOM should be a parse tree as generated by +`libxml-parse-html-region' or similar." (setq shr-content-cache nil) - (let ((shr-state nil) + (let ((start (point)) + (shr-state nil) (shr-start nil) (shr-base nil) (shr-width (or shr-width (window-width)))) - (shr-descend (shr-transform-dom dom)))) + (shr-descend (shr-transform-dom dom)) + (shr-remove-trailing-whitespace start (point)))) + +(defun shr-remove-trailing-whitespace (start end) + (let ((width (window-width))) + (save-restriction + (narrow-to-region start end) + (goto-char start) + (while (not (eobp)) + (end-of-line) + (when (> (shr-previous-newline-padding-width (current-column)) width) + (dolist (overlay (overlays-at (point))) + (when (overlay-get overlay 'before-string) + (overlay-put overlay 'before-string nil)))) + (forward-line 1))))) (defun shr-copy-url () "Copy the URL under point to the kill ring. @@ -164,7 +190,8 @@ redirects somewhere else." (when (re-search-forward ".utm_.*" nil t) (replace-match "" t t)) (message "Copied %s" (buffer-string)) - (copy-region-as-kill (point-min) (point-max))))))) + (copy-region-as-kill (point-min) (point-max))))) + nil t)) ;; Copy the URL to the kill ring. (t (with-temp-buffer @@ -180,14 +207,23 @@ redirects somewhere else." (message "No image under point") (message "%s" text)))) -(defun shr-browse-image () - "Browse the image under point." - (interactive) +(defun shr-browse-image (&optional copy-url) + "Browse the image under point. +If COPY-URL (the prefix if called interactively) is non-nil, copy +the URL of the image to the kill buffer instead." + (interactive "P") (let ((url (get-text-property (point) 'image-url))) - (if (not url) - (message "No image under point") + (cond + ((not url) + (message "No image under point")) + (copy-url + (with-temp-buffer + (insert url) + (copy-region-as-kill (point-min) (point-max)) + (message "Copied %s" url))) + (t (message "Browsing %s..." url) - (browse-url url)))) + (browse-url url))))) (defun shr-insert-image () "Insert the image under point into the buffer." @@ -198,6 +234,40 @@ redirects somewhere else." (message "Inserting %s..." url) (url-retrieve url 'shr-image-fetched (list (current-buffer) (1- (point)) (point-marker)) + t t)))) + +(defun shr-zoom-image () + "Toggle the image size. +The size will be rotated between the default size, the original +size, and full-buffer size." + (interactive) + (let ((url (get-text-property (point) 'image-url)) + (size (get-text-property (point) 'image-size)) + (buffer-read-only nil)) + (if (not url) + (message "No image under point") + ;; Delete the old picture. + (while (get-text-property (point) 'image-url) + (forward-char -1)) + (forward-char 1) + (let ((start (point))) + (while (get-text-property (point) 'image-url) + (forward-char 1)) + (forward-char -1) + (put-text-property start (point) 'display nil) + (when (> (- (point) start) 2) + (delete-region start (1- (point))))) + (message "Inserting %s..." url) + (url-retrieve url 'shr-image-fetched + (list (current-buffer) (1- (point)) (point-marker) + (list (cons 'size + (cond ((or (eq size 'default) + (null size)) + 'original) + ((eq size 'original) + 'full) + ((eq size 'full) + 'default))))) t)))) ;;; Utility functions. @@ -466,7 +536,7 @@ redirects somewhere else." ((not url) (message "No link under point")) ((string-match "^mailto:" url) - (browse-url-mailto url)) + (browse-url-mail url)) (t (browse-url url))))) @@ -477,7 +547,8 @@ redirects somewhere else." (if (not url) (message "No link under point") (url-retrieve (shr-encode-url url) - 'shr-store-contents (list url directory))))) + 'shr-store-contents (list url directory) + nil t)))) (defun shr-store-contents (status url directory) (unless (plist-get status :error) @@ -487,69 +558,97 @@ redirects somewhere else." (expand-file-name (file-name-nondirectory url) directory))))) -(defun shr-image-fetched (status buffer start end) - (when (and (buffer-name buffer) - (not (plist-get status :error))) - (url-store-in-cache (current-buffer)) - (when (or (search-forward "\n\n" nil t) - (search-forward "\r\n\r\n" nil t)) - (let ((data (buffer-substring (point) (point-max)))) - (with-current-buffer buffer - (save-excursion - (let ((alt (buffer-substring start end)) - (inhibit-read-only t)) - (delete-region start end) - (goto-char start) - (shr-put-image data alt))))))) - (kill-buffer (current-buffer))) - -(defun shr-put-image (data alt) +(defun shr-image-fetched (status buffer start end &optional flags) + (let ((image-buffer (current-buffer))) + (when (and (buffer-name buffer) + (not (plist-get status :error))) + (url-store-in-cache image-buffer) + (when (or (search-forward "\n\n" nil t) + (search-forward "\r\n\r\n" nil t)) + (let ((data (buffer-substring (point) (point-max)))) + (with-current-buffer buffer + (save-excursion + (let ((alt (buffer-substring start end)) + (properties (text-properties-at start)) + (inhibit-read-only t)) + (delete-region start end) + (goto-char start) + (funcall shr-put-image-function data alt flags) + (while properties + (let ((type (pop properties)) + (value (pop properties))) + (unless (memq type '(display image-size)) + (put-text-property start (point) type value)))))))))) + (kill-buffer image-buffer))) + +(defun shr-put-image (data alt &optional flags) + "Put image DATA with a string ALT. Return image." (if (display-graphic-p) - (let ((image (ignore-errors - (shr-rescale-image data)))) + (let* ((size (cdr (assq 'size flags))) + (start (point)) + (image (cond + ((eq size 'original) + (create-image data nil t :ascent 100)) + ((eq size 'full) + (ignore-errors + (shr-rescale-image data t))) + (t + (ignore-errors + (shr-rescale-image data)))))) (when image ;; When inserting big-ish pictures, put them at the ;; beginning of the line. (when (and (> (current-column) 0) (> (car (image-size image t)) 400)) (insert "\n")) - (insert-image image (or alt "*")))) + (if (eq size 'original) + (let ((overlays (overlays-at (point)))) + (insert-sliced-image image (or alt "*") nil 20 1) + (dolist (overlay overlays) + (overlay-put overlay 'face 'default))) + (insert-image image (or alt "*"))) + (put-text-property start (point) 'image-size size) + (when (image-animated-p image) + (image-animate image nil 60))) + image) (insert alt))) -(defun shr-rescale-image (data) - (if (or (not (fboundp 'imagemagick-types)) - (not (get-buffer-window (current-buffer)))) - (create-image data nil t) - (let* ((image (create-image data nil t)) - (size (image-size image t)) - (width (car size)) - (height (cdr size)) - (edges (window-inside-pixel-edges - (get-buffer-window (current-buffer)))) - (window-width (truncate (* shr-max-image-proportion - (- (nth 2 edges) (nth 0 edges))))) - (window-height (truncate (* shr-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))) - (when (and (fboundp 'create-animated-image) - (eq (image-type data nil t) 'gif)) - (setq image (create-animated-image data 'gif t))) - image))) +(defun shr-rescale-image (data &optional force) + "Rescale DATA, if too big, to fit the current buffer. +If FORCE, rescale the image anyway." + (let ((image (create-image data nil t :ascent 100))) + (if (or (not (fboundp 'imagemagick-types)) + (not (get-buffer-window (current-buffer)))) + image + (let* ((size (image-size image t)) + (width (car size)) + (height (cdr size)) + (edges (window-inside-pixel-edges + (get-buffer-window (current-buffer)))) + (window-width (truncate (* shr-max-image-proportion + (- (nth 2 edges) (nth 0 edges))))) + (window-height (truncate (* shr-max-image-proportion + (- (nth 3 edges) (nth 1 edges))))) + scaled-image) + (when (or force + (> height window-height)) + (setq image (or (create-image data 'imagemagick t + :height window-height + :ascent 100) + image)) + (setq size (image-size image t))) + (when (> (car size) window-width) + (setq image (or + (create-image data 'imagemagick t + :width window-width + :ascent 100) + image))) + image)))) ;; url-cache-extract autoloads url-cache. (declare-function url-cache-create-filename "url-cache" (url)) (autoload 'mm-disable-multibyte "mm-util") -(autoload 'browse-url-mailto "browse-url") +(autoload 'browse-url-mail "browse-url") (defun shr-get-image-data (url) "Get image data for URL. @@ -567,7 +666,7 @@ Return a string with image data." "Return a function to display an image. CONTENT-FUNCTION is a function to retrieve an image for a cid url that is an argument. The function to be returned takes three arguments URL, -START, and END. Note that START and END should be merkers." +START, and END. Note that START and END should be markers." `(lambda (url start end) (when url (if (string-match "\\`cid:" url) @@ -576,12 +675,12 @@ START, and END. Note that START and END should be merkers." (substring url (match-end 0))))) (when image (goto-char start) - (shr-put-image image - (buffer-substring-no-properties start end)) + (funcall shr-put-image-function + image (buffer-substring start end)) (delete-region (point) end)))) (url-retrieve url 'shr-image-fetched (list (current-buffer) start end) - t))))) + t t))))) (defun shr-heading (cont &rest types) (shr-ensure-paragraph) @@ -596,7 +695,7 @@ START, and END. Note that START and END should be merkers." :help-echo (if title (format "%s (%s)" url title) url) :keymap shr-map url) - (put-text-property start (point) 'face 'shr-link) + (shr-add-font start (point) 'shr-link) (put-text-property start (point) 'shr-url url)) (defun shr-encode-url (url) @@ -638,7 +737,7 @@ ones, in case fg and bg are nil." (shr-put-color start end :background (car new-colors)))) new-colors))) -;; Put a color in the region, but avoid putting colors on on blank +;; Put a color in the region, but avoid putting colors on blank ;; text at the start of the line, and the newline at the end, to avoid ;; ugliness. Also, don't overwrite any existing color information, ;; since this can be called recursively, and we want the "inner" color @@ -711,7 +810,8 @@ ones, in case fg and bg are nil." (defun shr-put-color-1 (start end type color) (let* ((old-props (get-text-property start 'face)) - (do-put (not (memq type old-props))) + (do-put (and (listp old-props) + (not (memq type old-props)))) change) (while (< start end) (setq change (next-single-property-change start 'face nil end)) @@ -719,7 +819,8 @@ ones, in case fg and bg are nil." (put-text-property start change 'face (nconc (list type color) old-props))) (setq old-props (get-text-property change 'face)) - (setq do-put (not (memq type old-props))) + (setq do-put (and (listp old-props) + (not (memq type old-props)))) (setq start change)) (when (and do-put (> end start)) @@ -744,6 +845,9 @@ ones, in case fg and bg are nil." (defun shr-tag-script (cont) ) +(defun shr-tag-comment (cont) + ) + (defun shr-tag-sup (cont) (let ((start (point))) (shr-generic cont) @@ -773,6 +877,9 @@ ones, in case fg and bg are nil." (defun shr-tag-s (cont) (shr-fontize-cont cont 'shr-strike-through)) +(defun shr-tag-del (cont) + (shr-fontize-cont cont 'shr-strike-through)) + (defun shr-tag-b (cont) (shr-fontize-cont cont 'bold)) @@ -864,7 +971,7 @@ ones, in case fg and bg are nil." (if (or (not shr-content-function) (not (setq image (funcall shr-content-function url)))) (insert alt) - (shr-put-image image alt)))) + (funcall shr-put-image-function image alt)))) ((or shr-inhibit-images (and shr-blocked-images (string-match shr-blocked-images url))) @@ -873,23 +980,27 @@ ones, in case fg and bg are nil." (if (> (string-width alt) 8) (shr-insert (truncate-string-to-width alt 8)) (shr-insert alt)))) - ((url-is-cached (shr-encode-url url)) - (shr-put-image (shr-get-image-data url) alt)) + ((and (not shr-ignore-cache) + (url-is-cached (shr-encode-url url))) + (funcall shr-put-image-function (shr-get-image-data url) alt)) (t - (insert alt) - (funcall - (if (fboundp 'url-queue-retrieve) - 'url-queue-retrieve - 'url-retrieve) + (insert alt " ") + (when (and shr-ignore-cache + (url-is-cached (shr-encode-url url))) + (let ((file (url-cache-create-filename (shr-encode-url url)))) + (when (file-exists-p file) + (delete-file file)))) + (url-queue-retrieve (shr-encode-url url) 'shr-image-fetched - (list (current-buffer) start (point-marker)) - t))) - (put-text-property start (point) 'keymap shr-map) - (put-text-property start (point) 'shr-alt alt) - (put-text-property start (point) 'image-url url) - (put-text-property start (point) 'image-displayer - (shr-image-displayer shr-content-function)) - (put-text-property start (point) 'help-echo alt) + (list (current-buffer) start (set-marker (make-marker) (1- (point)))) + t t))) + (when (zerop shr-table-depth) ;; We are not in a table. + (put-text-property start (point) 'keymap shr-map) + (put-text-property start (point) 'shr-alt alt) + (put-text-property start (point) 'image-url url) + (put-text-property start (point) 'image-displayer + (shr-image-displayer shr-content-function)) + (put-text-property start (point) 'help-echo alt)) (setq shr-state 'image))))) (defun shr-tag-pre (cont) @@ -1025,44 +1136,53 @@ ones, in case fg and bg are nil." (nheader (if header (shr-max-columns header))) (nbody (if body (shr-max-columns body))) (nfooter (if footer (shr-max-columns footer)))) - (shr-tag-table-1 - (nconc - (if caption `((tr (td ,@caption)))) - (if header - (if footer - ;; hader + body + footer + (if (and (not caption) + (not header) + (not (cdr (assq 'tbody cont))) + (not (cdr (assq 'tr cont))) + (not footer)) + ;; The table is totally invalid and just contains random junk. + ;; Try to output it anyway. + (shr-generic cont) + ;; It's a real table, so render it. + (shr-tag-table-1 + (nconc + (if caption `((tr (td ,@caption)))) + (if header + (if footer + ;; hader + body + footer + (if (= nheader nbody) + (if (= nbody nfooter) + `((tr (td (table (tbody ,@header ,@body ,@footer))))) + (nconc `((tr (td (table (tbody ,@header ,@body))))) + (if (= nfooter 1) + footer + `((tr (td (table (tbody ,@footer)))))))) + (nconc `((tr (td (table (tbody ,@header))))) + (if (= nbody nfooter) + `((tr (td (table (tbody ,@body ,@footer))))) + (nconc `((tr (td (table (tbody ,@body))))) + (if (= nfooter 1) + footer + `((tr (td (table (tbody ,@footer)))))))))) + ;; header + body (if (= nheader nbody) - (if (= nbody nfooter) - `((tr (td (table (tbody ,@header ,@body ,@footer))))) - (nconc `((tr (td (table (tbody ,@header ,@body))))) - (if (= nfooter 1) - footer - `((tr (td (table (tbody ,@footer)))))))) - (nconc `((tr (td (table (tbody ,@header))))) - (if (= nbody nfooter) - `((tr (td (table (tbody ,@body ,@footer))))) - (nconc `((tr (td (table (tbody ,@body))))) - (if (= nfooter 1) - footer - `((tr (td (table (tbody ,@footer)))))))))) - ;; header + body - (if (= nheader nbody) - `((tr (td (table (tbody ,@header ,@body))))) - (if (= nheader 1) - `(,@header (tr (td (table (tbody ,@body))))) - `((tr (td (table (tbody ,@header)))) - (tr (td (table (tbody ,@body)))))))) - (if footer - ;; body + footer - (if (= nbody nfooter) - `((tr (td (table (tbody ,@body ,@footer))))) - (nconc `((tr (td (table (tbody ,@body))))) - (if (= nfooter 1) - footer - `((tr (td (table (tbody ,@footer)))))))) - (if caption - `((tr (td (table (tbody ,@body))))) - body))))) + `((tr (td (table (tbody ,@header ,@body))))) + (if (= nheader 1) + `(,@header (tr (td (table (tbody ,@body))))) + `((tr (td (table (tbody ,@header)))) + (tr (td (table (tbody ,@body)))))))) + (if footer + ;; body + footer + (if (= nbody nfooter) + `((tr (td (table (tbody ,@body ,@footer))))) + (nconc `((tr (td (table (tbody ,@body))))) + (if (= nfooter 1) + footer + `((tr (td (table (tbody ,@footer)))))))) + (if caption + `((tr (td (table (tbody ,@body))))) + body)))))) (when bgcolor (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet)) bgcolor)))) @@ -1137,21 +1257,26 @@ ones, in case fg and bg are nil." (aset natural-widths i (max (aref natural-widths i) (cadr column))) (setq i (1+ i))))) - (let ((extra (- (apply '+ (append suggested-widths nil)) - (apply '+ (append widths nil)))) - (expanded-columns 0)) + (let* ((total-suggested (apply '+ (append suggested-widths nil))) + (total-actual (apply '+ (append widths nil))) + (extra (- total-suggested + total-actual + ;; TD separators. + (length widths) + ;; Table separators + fence. + 3 + (* 2 shr-table-depth))) + (expanded-columns 0)) + ;; We have extra, unused space, so divide this space amongst the + ;; columns. (when (> extra 0) + ;; If the natural width is wider than the rendered width, we + ;; want to allow the column to expand. (dotimes (i length) - ;; If the natural width is wider than the rendered width, we - ;; want to allow the column to expand. - (when (> (aref natural-widths i) (aref widths i)) - (setq expanded-columns (1+ expanded-columns)))) - (dotimes (i length) - (when (> (aref natural-widths i) (aref widths i)) - (aset widths i (min - (1+ (aref natural-widths i)) - (+ (/ extra expanded-columns) - (aref widths i)))))))) + (when (> (aref natural-widths i) 0) + (aset widths i (+ (truncate (* (/ extra (* 1.0 total-actual)) + (aref widths i))) + (aref widths i))))))) widths)) (defun shr-make-table (cont widths &optional fill) @@ -1204,10 +1329,13 @@ ones, in case fg and bg are nil." (let ((shr-width width) (shr-indentation 0)) (shr-descend (cons 'td cont))) + ;; Delete padding at the bottom of the TDs. (delete-region (point) - (+ (point) - (skip-chars-backward " \t\n"))) + (progn + (skip-chars-backward " \t\n") + (end-of-line) + (point))) (push (list (cons width cont) (buffer-string) (shr-overlays-in-region (point-min) (point-max))) shr-content-cache))) @@ -1303,10 +1431,10 @@ ones, in case fg and bg are nil." (when (memq (car column) '(td th)) (let ((width (cdr (assq :width (cdr column))))) (when (and width - (string-match "\\([0-9]+\\)%" width)) - (aset columns i - (/ (string-to-number (match-string 1 width)) - 100.0)))) + (string-match "\\([0-9]+\\)%" width) + (not (zerop (setq width (string-to-number + (match-string 1 width)))))) + (aset columns i (/ width 100.0)))) (setq i (1+ i))))))) columns))