X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fshr.el;h=9284da4c4b3222554d1ba25698ae359f61f1638a;hb=378aea34bb2b6ea37439350a3d432fd510b8e223;hp=f46afaa7207b59f2dd86f0f587b76865b6f7c051;hpb=805a2f5d5bfe7110709d7e092c8b9427d73dc672;p=gnus

diff --git a/lisp/shr.el b/lisp/shr.el
index f46afaa72..9284da4c4 100644
--- a/lisp/shr.el
+++ b/lisp/shr.el
@@ -1,6 +1,6 @@
 ;;; shr.el --- Simple HTML Renderer
 
-;; Copyright (C) 2010-2012 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: html
@@ -52,7 +52,7 @@ fit these criteria."
   "Images that have URLs matching this regexp will be blocked."
   :version "24.1"
   :group 'shr
-  :type 'regexp)
+  :type '(choice (const nil) regexp))
 
 (defcustom shr-table-horizontal-line ?\s
   "Character used to draw horizontal table lines."
@@ -129,17 +129,23 @@ 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: ")
+(defun shr-render-buffer (buffer)
+  "Display the HTML rendering of the current buffer."
+  (interactive (list (current-buffer)))
   (pop-to-buffer "*html*")
   (erase-buffer)
   (shr-insert-document
-   (with-temp-buffer
-     (insert-file-contents file)
+   (with-current-buffer buffer
      (libxml-parse-html-region (point-min) (point-max))))
   (goto-char (point-min)))
 
+(defun shr-visit-file (file)
+  "Parse FILE as an HTML document, and render it in a new buffer."
+  (interactive "fHTML file name: ")
+  (with-temp-buffer
+    (insert-file-contents file)
+    (shr-render-buffer (current-buffer))))
+
 ;;;###autoload
 (defun shr-insert-document (dom)
   "Render the parsed document DOM into the current buffer.
@@ -333,6 +339,7 @@ size, and full-buffer size."
 
 (defun shr-insert (text)
   (when (and (eq shr-state 'image)
+	     (not (bolp))
 	     (not (string-match "\\`[ \t\n]+\\'" text)))
     (insert "\n")
     (setq shr-state nil))
@@ -340,11 +347,11 @@ size, and full-buffer size."
    ((eq shr-folding-mode 'none)
     (insert text))
    (t
-    (when (and (string-match "\\`[ \t\n ]" text)
+    (when (and (string-match "\\`[ \t\n ]" text)
 	       (not (bolp))
 	       (not (eq (char-after (1- (point))) ? )))
       (insert " "))
-    (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t))
+    (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t))
       (when (and (bolp)
 		 (> shr-indentation 0))
 	(shr-indent))
@@ -367,6 +374,7 @@ size, and full-buffer size."
       (unless shr-start
 	(setq shr-start (point)))
       (insert elem)
+      (setq shr-state nil)
       (let (found)
 	(while (and (> (current-column) shr-width)
 		    (progn
@@ -383,7 +391,7 @@ size, and full-buffer size."
 	    (shr-indent))
 	  (end-of-line))
 	(insert " ")))
-    (unless (string-match "[ \t\n ]\\'" text)
+    (unless (string-match "[ \t\r\n ]\\'" text)
       (delete-char -1)))))
 
 (defun shr-find-fill-point ()
@@ -442,32 +450,29 @@ size, and full-buffer size."
 			 (shr-char-kinsoku-eol-p (following-char)))))
 	   (goto-char bp)))
 	((shr-char-kinsoku-eol-p (preceding-char))
-	 (if (shr-char-kinsoku-eol-p (following-char))
-	     ;; There are consecutive kinsoku-eol characters.
-	     (setq failed t)
-	   (let ((count 4))
-	     (while
-		 (progn
-		   (backward-char 1)
-		   (and (> (setq count (1- count)) 0)
-			(not (memq (preceding-char) (list ?\C-@ ?\n ? )))
-			(or (shr-char-kinsoku-eol-p (preceding-char))
-			    (shr-char-kinsoku-bol-p (following-char)))))))
-	   (if (setq failed (= (current-column) shr-indentation))
-	       ;; There's no breakable point that doesn't violate kinsoku,
-	       ;; so we go to the second best position.
-	       (if (looking-at "\\(\\c<+\\)\\c<")
-		   (goto-char (match-end 1))
-		 (forward-char 1)))))
-	(t
-	 (if (shr-char-kinsoku-bol-p (preceding-char))
-	     ;; There are consecutive kinsoku-bol characters.
-	     (setq failed t)
-	   (let ((count 4))
-	     (while (and (>= (setq count (1- count)) 0)
+	 ;; Find backward the point where kinsoku-eol characters begin.
+	 (let ((count 4))
+	   (while
+	       (progn
+		 (backward-char 1)
+		 (and (> (setq count (1- count)) 0)
+		      (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
+		      (or (shr-char-kinsoku-eol-p (preceding-char))
+			  (shr-char-kinsoku-bol-p (following-char)))))))
+	 (if (setq failed (= (current-column) shr-indentation))
+	     ;; There's no breakable point that doesn't violate kinsoku,
+	     ;; so we go to the second best position.
+	     (if (looking-at "\\(\\c<+\\)\\c<")
+		 (goto-char (match-end 1))
+	       (forward-char 1))))
+	((shr-char-kinsoku-bol-p (following-char))
+	 ;; Find forward the point where kinsoku-bol characters end.
+	 (let ((count 4))
+	   (while (progn
+		    (forward-char 1)
+		    (and (>= (setq count (1- count)) 0)
 			 (shr-char-kinsoku-bol-p (following-char))
-			 (shr-char-breakable-p (following-char)))
-	       (forward-char 1))))))
+			 (shr-char-breakable-p (following-char))))))))
        (when (eq (following-char) ? )
 	 (forward-char 1))))
     (not failed)))
@@ -479,6 +484,9 @@ size, and full-buffer size."
 	(string-match "\\`[a-z]*:" url)
 	(not shr-base))
     url)
+   ((and (string-match "\\`//" url)
+	 (string-match "\\`[a-z]*:" shr-base))
+    (concat (match-string 0 shr-base) url))
    ((and (not (string-match "/\\'" shr-base))
 	 (not (string-match "\\`/" url)))
     (concat shr-base "/" url))
@@ -499,7 +507,7 @@ size, and full-buffer size."
       (if (save-excursion
 	    (beginning-of-line)
 	    (looking-at " *$"))
-	  (insert "\n")
+	  (delete-region (match-beginning 0) (match-end 0))
 	(insert "\n\n")))))
 
 (defun shr-indent ()
@@ -512,6 +520,11 @@ size, and full-buffer size."
     (dolist (type types)
       (shr-add-font (or shr-start (point)) (point) type))))
 
+(defun shr-make-overlay (beg end &optional buffer front-advance rear-advance)
+  (let ((overlay (make-overlay beg end buffer front-advance rear-advance)))
+    (overlay-put overlay 'evaporate t)
+    overlay))
+
 ;; Add an overlay in the region, but avoid putting the font properties
 ;; on blank text at the start of the line, and the newline at the end,
 ;; to avoid ugliness.
@@ -521,7 +534,7 @@ size, and full-buffer size."
     (while (< (point) end)
       (when (bolp)
 	(skip-chars-forward " "))
-      (let ((overlay (make-overlay (point) (min (line-end-position) end))))
+      (let ((overlay (shr-make-overlay (point) (min (line-end-position) end))))
 	(overlay-put overlay 'face type))
       (if (< (line-end-position) end)
 	  (forward-line 1)
@@ -580,6 +593,17 @@ size, and full-buffer size."
 		      (put-text-property start (point) type value))))))))))
     (kill-buffer image-buffer)))
 
+(defun shr-image-from-data (data)
+  "Return an image from the data: URI content DATA."
+  (when (string-match
+	 "\\(\\([^/;,]+\\(/[^;,]+\\)?\\)\\(;[^;,]+\\)*\\)?,\\(.*\\)"
+	 data)
+    (let ((param (match-string 4 data))
+	  (payload (url-unhex-string (match-string 5 data))))
+      (when (string-match "^.*\\(;[ \t]*base64\\)$" param)
+	(setq payload (base64-decode-string payload)))
+      payload)))
+
 (defun shr-put-image (data alt &optional flags)
   "Put image DATA with a string ALT.  Return image."
   (if (display-graphic-p)
@@ -607,7 +631,13 @@ size, and full-buffer size."
 		  (overlay-put overlay 'face 'default)))
 	    (insert-image image (or alt "*")))
 	  (put-text-property start (point) 'image-size size)
-	  (when (image-animated-p image)
+	  (when (cond ((fboundp 'image-multi-frame-p)
+		       ;; Only animate multi-frame things that specify a
+		       ;; delay; eg animated gifs as opposed to
+		       ;; multi-page tiffs.  FIXME?
+		       (cdr (image-multi-frame-p image)))
+		      ((fboundp 'image-animated-p)
+		       (image-animated-p image)))
 	    (image-animate image nil 60)))
 	image)
     (insert alt)))
@@ -777,7 +807,7 @@ ones, in case fg and bg are nil."
 	(when (and (< (setq column (current-column)) width)
 		   (< (setq column (shr-previous-newline-padding-width column))
 		      width))
-	  (let ((overlay (make-overlay (point) (1+ (point)))))
+	  (let ((overlay (shr-make-overlay (point) (1+ (point)))))
 	    (overlay-put overlay 'before-string
 			 (concat
 			  (mapconcat
@@ -886,7 +916,7 @@ ones, in case fg and bg are nil."
   (shr-fontize-cont cont 'italic))
 
 (defun shr-tag-em (cont)
-  (shr-fontize-cont cont 'bold))
+  (shr-fontize-cont cont 'italic))
 
 (defun shr-tag-strong (cont)
   (shr-fontize-cont cont 'bold))
@@ -923,7 +953,8 @@ ones, in case fg and bg are nil."
 	(start (point))
 	shr-start)
     (shr-generic cont)
-    (shr-urlify (or shr-start start) (shr-expand-url url) title)))
+    (when url
+      (shr-urlify (or shr-start start) (shr-expand-url url) title))))
 
 (defun shr-tag-object (cont)
   (let ((start (point))
@@ -963,6 +994,12 @@ ones, in case fg and bg are nil."
 	      (member (cdr (assq :width cont)) '("0" "1")))
 	  ;; Ignore zero-sized or single-pixel images.
 	  )
+	 ((and (not shr-inhibit-images)
+	       (string-match "\\`data:" url))
+	  (let ((image (shr-image-from-data (substring url (match-end 0)))))
+	    (if image
+		(funcall shr-put-image-function image alt)
+	      (insert alt))))
 	 ((and (not shr-inhibit-images)
 	       (string-match "\\`cid:" url))
 	  (let ((url (substring url (match-end 0)))
@@ -1042,11 +1079,24 @@ ones, in case fg and bg are nil."
     (shr-generic cont)))
 
 (defun shr-tag-br (cont)
-  (unless (bolp)
+  (when (and (not (bobp))
+	     ;; Only add a newline if we break the current line, or
+	     ;; the previous line isn't a blank line.
+	     (or (not (bolp))
+		 (and (> (- (point) 2) (point-min))
+		      (not (= (char-after (- (point) 2)) ?\n)))))
     (insert "\n")
     (shr-indent))
   (shr-generic cont))
 
+(defun shr-tag-span (cont)
+  (let ((title (cdr (assq :title cont))))
+    (shr-generic cont)
+    (when title
+      (when shr-start
+        (let ((overlay (shr-make-overlay shr-start (point))))
+          (overlay-put overlay 'help-echo title))))))
+
 (defun shr-tag-h1 (cont)
   (shr-heading cont 'bold 'underline))
 
@@ -1219,8 +1269,8 @@ ones, in case fg and bg are nil."
 	    (end-of-line)
 	    (insert line shr-table-vertical-line)
 	    (dolist (overlay overlay-line)
-	      (let ((o (make-overlay (- (point) (nth 0 overlay) 1)
-				     (- (point) (nth 1 overlay) 1)))
+	      (let ((o (shr-make-overlay (- (point) (nth 0 overlay) 1)
+					 (- (point) (nth 1 overlay) 1)))
 		    (properties (nth 2 overlay)))
 		(while properties
 		  (overlay-put o (pop properties) (pop properties)))))
@@ -1321,8 +1371,8 @@ ones, in case fg and bg are nil."
 	      (let ((end (length (car cache))))
 		(dolist (overlay (cadr cache))
 		  (let ((new-overlay
-			 (make-overlay (1+ (- end (nth 0 overlay)))
-				       (1+ (- end (nth 1 overlay)))))
+			 (shr-make-overlay (1+ (- end (nth 0 overlay)))
+					   (1+ (- end (nth 1 overlay)))))
 			(properties (nth 2 overlay)))
 		    (while properties
 		      (overlay-put new-overlay
@@ -1451,4 +1501,8 @@ ones, in case fg and bg are nil."
 
 (provide 'shr)
 
+;; Local Variables:
+;; coding: utf-8
+;; End:
+
 ;;; shr.el ends here