X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fshr.el;h=5021eabb557e69a30cacb4f9745b49082147f84d;hp=83392cd9ff3b01e4c92f75c9b9ea434884430475;hb=9f6c66f015b581961a17e95720b753d10d772677;hpb=81f7131c6375332dcc584797020db2e31f22d5d6 diff --git a/lisp/shr.el b/lisp/shr.el index 83392cd9f..5021eabb5 100644 --- a/lisp/shr.el +++ b/lisp/shr.el @@ -35,6 +35,7 @@ (defgroup shr nil "Simple HTML Renderer" + :version "24.1" :group 'mail) (defcustom shr-max-image-proportion 0.9 @@ -129,6 +130,7 @@ 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) @@ -140,12 +142,30 @@ cid: URL as the argument.") ;;;###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. @@ -170,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 @@ -213,7 +234,7 @@ the URL of the image to the kill buffer instead." (message "Inserting %s..." url) (url-retrieve url 'shr-image-fetched (list (current-buffer) (1- (point)) (point-marker)) - t)))) + t t)))) (defun shr-zoom-image () "Toggle the image size. @@ -354,8 +375,8 @@ size, and full-buffer size." (when (eq (preceding-char) ? ) (delete-char -1)) (insert "\n") + (put-text-property (1- (point)) (point) 'shr-break t) (unless found - (put-text-property (1- (point)) (point) 'shr-break t) ;; No space is needed at the beginning of a line. (when (eq (following-char) ? ) (delete-char 1))) @@ -526,7 +547,8 @@ size, and full-buffer size." (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) @@ -537,26 +559,27 @@ size, and full-buffer size." directory))))) (defun shr-image-fetched (status buffer start end &optional flags) - (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)) - (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 (current-buffer))) + (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." @@ -657,7 +680,7 @@ START, and END. Note that START and END should be markers." (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) @@ -967,13 +990,10 @@ ones, in case fg and bg are nil." (let ((file (url-cache-create-filename (shr-encode-url url)))) (when (file-exists-p file) (delete-file file)))) - (funcall - (if (fboundp 'url-queue-retrieve) - 'url-queue-retrieve - 'url-retrieve) + (url-queue-retrieve (shr-encode-url url) 'shr-image-fetched (list (current-buffer) start (set-marker (make-marker) (1- (point)))) - t))) + 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) @@ -1237,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) @@ -1304,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))) @@ -1351,7 +1379,8 @@ ones, in case fg and bg are nil." (while (not (eobp)) (end-of-line) (setq current (+ current (current-column))) - (unless (get-text-property (point) 'shr-break) + (if (get-text-property (point) 'shr-break) + (incf current) (setq max (max max current) current 0)) (forward-line 1)) @@ -1403,10 +1432,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))