X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fshr.el;h=f3c75ccd6a31c5db06e40a4c4bef2092c74accb4;hb=c85ff27626350a909ee39474fecac012fec8cd26;hp=a41ebf11b0c0a5fdefadc17684143ee8637b6007;hpb=7e6ce097f0b39ce9af188578cd6417c74f2171d0;p=gnus diff --git a/lisp/shr.el b/lisp/shr.el index a41ebf11b..f3c75ccd6 100644 --- a/lisp/shr.el +++ b/lisp/shr.el @@ -1,6 +1,6 @@ ;;; shr.el --- Simple HTML Renderer -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010-2011 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: html @@ -74,8 +74,12 @@ fit these criteria." :type 'character) (defcustom shr-width fill-column - "Frame width to use for rendering." - :type 'integer + "Frame width to use for rendering. +May either be an integer specifying a fixed width in characters, +or nil, meaning that the full width of the window should be +used." + :type '(choice (integer :tag "Fixed width in characters") + (const :tag "Use the width of the window" nil)) :group 'shr) (defvar shr-content-function nil @@ -113,7 +117,8 @@ cid: URL as the argument.") (defun shr-insert-document (dom) (setq shr-content-cache nil) (let ((shr-state nil) - (shr-start nil)) + (shr-start nil) + (shr-width (or shr-width (window-width)))) (shr-descend (shr-transform-dom dom)))) (defun shr-copy-url () @@ -253,16 +258,12 @@ redirects somewhere else." (when (and (bolp) (> shr-indentation 0)) (shr-indent)) - ;; The shr-start is a special variable that is used to pass - ;; upwards the first point in the buffer where the text really - ;; starts. - (unless shr-start - (setq shr-start (point))) ;; No space is needed behind a wide character categorized as ;; kinsoku-bol, between characters both categorized as nospace, ;; or at the beginning of a line. (let (prev) - (when (and (eq (preceding-char) ? ) + (when (and (> (current-column) shr-indentation) + (eq (preceding-char) ? ) (or (= (line-beginning-position) (1- (point))) (and (shr-char-breakable-p (setq prev (char-after (- (point) 2)))) @@ -270,6 +271,11 @@ redirects somewhere else." (and (shr-char-nospace-p prev) (shr-char-nospace-p (aref elem 0))))) (delete-char -1))) + ;; The shr-start is a special variable that is used to pass + ;; upwards the first point in the buffer where the text really + ;; starts. + (unless shr-start + (setq shr-start (point))) (insert elem) (let (found) (while (and (> (current-column) shr-width) @@ -304,8 +310,8 @@ redirects somewhere else." (if (eq (preceding-char) ?') (not (memq (char-after (- (point) 2)) (list nil ?\n ? ))) - ;; There're some kinsoku CJK chars that aren't breakable. (and (shr-char-kinsoku-bol-p (preceding-char)) + (shr-char-breakable-p (following-char)) (not (shr-char-kinsoku-bol-p (following-char))))) (shr-char-kinsoku-eol-p (following-char)))) (backward-char 1)) @@ -456,11 +462,12 @@ redirects somewhere else." (search-forward "\r\n\r\n" nil t)) (let ((data (buffer-substring (point) (point-max)))) (with-current-buffer buffer - (let ((alt (buffer-substring start end)) - (inhibit-read-only t)) - (delete-region start end) - (goto-char start) - (shr-put-image data alt)))))) + (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) @@ -501,6 +508,9 @@ redirects somewhere else." (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))) ;; url-cache-extract autoloads url-cache. @@ -524,7 +534,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." +START, and END. Note that START and END should be merkers." `(lambda (url start end) (when url (if (string-match "\\`cid:" url) @@ -534,9 +544,8 @@ START, and END." (when image (goto-char start) (shr-put-image image - (prog1 - (buffer-substring-no-properties start end) - (delete-region start end)))))) + (buffer-substring-no-properties start end)) + (delete-region (point) end)))) (url-retrieve url 'shr-image-fetched (list (current-buffer) start end) t))))) @@ -589,7 +598,8 @@ ones, in case fg and bg are nil." (when (or fg bg) (let ((new-colors (shr-color-check fg bg))) (when new-colors - (shr-put-color start end :foreground (cadr new-colors)) + (when fg + (shr-put-color start end :foreground (cadr new-colors))) (when bg (shr-put-color start end :background (car new-colors))))))) @@ -602,13 +612,67 @@ ones, in case fg and bg are nil." (save-excursion (goto-char start) (while (< (point) end) - (when (bolp) + (when (and (bolp) + (not (eq type :background))) (skip-chars-forward " ")) (when (> (line-end-position) (point)) (shr-put-color-1 (point) (min (line-end-position) end) type color)) (if (< (line-end-position) end) (forward-line 1) - (goto-char end))))) + (goto-char end))) + (when (and (eq type :background) + (= shr-table-depth 0)) + (shr-expand-newlines start end color)))) + +(defun shr-expand-newlines (start end color) + (save-restriction + ;; Skip past all white space at the start and ends. + (goto-char start) + (skip-chars-forward " \t\n") + (beginning-of-line) + (setq start (point)) + (goto-char end) + (skip-chars-backward " \t\n") + (forward-line 1) + (setq end (point)) + (narrow-to-region start end) + (let ((width (shr-natural-width)) + column) + (goto-char (point-min)) + (while (not (eobp)) + (end-of-line) + (when (and (< (setq column (current-column)) width) + (< (setq column (shr-previous-newline-padding-width column)) + width)) + (let ((overlay (make-overlay (point) (1+ (point))))) + (overlay-put overlay 'before-string + (concat + (mapconcat + (lambda (overlay) + (let ((string (plist-get + (overlay-properties overlay) + 'before-string))) + (if (not string) + "" + (overlay-put overlay 'before-string "") + string))) + (overlays-at (point)) + "") + (propertize (make-string (- width column) ? ) + 'face (list :background color)))))) + (forward-line 1))))) + +(defun shr-previous-newline-padding-width (width) + (let ((overlays (overlays-at (point))) + (previous-width 0)) + (if (null overlays) + width + (dolist (overlay overlays) + (setq previous-width + (+ previous-width + (length (plist-get (overlay-properties overlay) + 'before-string))))) + (+ width previous-width)))) (defun shr-put-color-1 (start end type color) (let* ((old-props (get-text-property start 'face)) @@ -638,6 +702,16 @@ ones, in case fg and bg are nil." (shr-generic cont) (shr-colorize-region start (point) fgcolor bgcolor))) +(defun shr-tag-style (cont) + ) + +(defun shr-tag-script (cont) + ) + +(defun shr-tag-label (cont) + (shr-generic cont) + (shr-ensure-paragraph)) + (defun shr-tag-p (cont) (shr-ensure-paragraph) (shr-indent) @@ -893,6 +967,9 @@ ones, in case fg and bg are nil." (body (or (cdr (assq 'tbody cont)) cont)) (footer (cdr (assq 'tfoot cont))) (bgcolor (cdr (assq :bgcolor cont))) + (start (point)) + (shr-stylesheet (nconc (list (cons 'background-color bgcolor)) + shr-stylesheet)) (nheader (if header (shr-max-columns header))) (nbody (if body (shr-max-columns body))) (nfooter (if footer (shr-max-columns footer)))) @@ -933,7 +1010,10 @@ ones, in case fg and bg are nil." `((tr (td (table (tbody ,@footer)))))))) (if caption `((tr (td (table (tbody ,@body))))) - body))))))) + body))))) + (when bgcolor + (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet)) + bgcolor)))) (defun shr-find-elements (cont type) (let (result) @@ -1039,43 +1119,73 @@ ones, in case fg and bg are nil." (defun shr-render-td (cont width fill) (with-temp-buffer - (let ((cache (cdr (assoc (cons width cont) shr-content-cache)))) - (if cache - (insert cache) - (let ((shr-width width) - (shr-indentation 0)) - (shr-descend (cons 'td cont))) - (delete-region - (point) - (+ (point) - (skip-chars-backward " \t\n"))) - (push (cons (cons width cont) (buffer-string)) - shr-content-cache))) - (goto-char (point-min)) - (let ((max 0)) - (while (not (eobp)) - (end-of-line) - (setq max (max max (current-column))) - (forward-line 1)) - (when fill - (goto-char (point-min)) - ;; If the buffer is totally empty, then put a single blank - ;; line here. - (if (zerop (buffer-size)) - (insert (make-string width ? )) - ;; Otherwise, fill the buffer. - (while (not (eobp)) - (end-of-line) - (when (> (- width (current-column)) 0) - (insert (make-string (- width (current-column)) ? ))) - (forward-line 1)))) - (if fill + (let ((bgcolor (cdr (assq :bgcolor cont))) + (fgcolor (cdr (assq :fgcolor cont))) + (style (cdr (assq :style cont))) + (shr-stylesheet shr-stylesheet) + overlays) + (when style + (setq style (and (string-match "color" style) + (shr-parse-style style)))) + (when bgcolor + (setq style (nconc (list (cons 'background-color bgcolor)) style))) + (when fgcolor + (setq style (nconc (list (cons 'color fgcolor)) style))) + (when style + (setq shr-stylesheet (append style shr-stylesheet))) + (let ((cache (cdr (assoc (cons width cont) shr-content-cache)))) + (if cache + (progn + (insert (car cache)) + (let ((end (length (car cache)))) + (dolist (overlay (cadr cache)) + (let ((new-overlay + (make-overlay (1+ (- end (nth 0 overlay))) + (1+ (- end (nth 1 overlay))))) + (properties (nth 2 overlay))) + (while properties + (overlay-put new-overlay + (pop properties) (pop properties))))))) + (let ((shr-width width) + (shr-indentation 0)) + (shr-descend (cons 'td cont))) + (delete-region + (point) + (+ (point) + (skip-chars-backward " \t\n"))) + (push (list (cons width cont) (buffer-string) + (shr-overlays-in-region (point-min) (point-max))) + shr-content-cache))) + (goto-char (point-min)) + (let ((max 0)) + (while (not (eobp)) + (end-of-line) + (setq max (max max (current-column))) + (forward-line 1)) + (when fill + (goto-char (point-min)) + ;; If the buffer is totally empty, then put a single blank + ;; line here. + (if (zerop (buffer-size)) + (insert (make-string width ? )) + ;; Otherwise, fill the buffer. + (while (not (eobp)) + (end-of-line) + (when (> (- width (current-column)) 0) + (insert (make-string (- width (current-column)) ? ))) + (forward-line 1)))) + (when style + (shr-colorize-region + (point-min) (point-max) + (cdr (assq 'color shr-stylesheet)) + (cdr (assq 'background-color shr-stylesheet)))) + (if fill + (list max + (count-lines (point-min) (point-max)) + (split-string (buffer-string) "\n") + (shr-collect-overlays)) (list max - (count-lines (point-min) (point-max)) - (split-string (buffer-string) "\n") - (shr-collect-overlays)) - (list max - (shr-natural-width)))))) + (shr-natural-width))))))) (defun shr-natural-width () (goto-char (point-min))