X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/99191b89ff64172740add88e67f163619a07830c..eca36e921340e4fe3a0f7797c1a7b6201c32b840:/lisp/net/shr.el

diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 89791511e0..58442575ad 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -1,6 +1,6 @@
 ;;; shr.el --- Simple HTML Renderer
 
-;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: html
@@ -59,7 +59,7 @@ fit these criteria."
   "Character used to draw horizontal table lines.
 If nil, don't draw horizontal table lines."
   :group 'shr
-  :type 'character)
+  :type '(choice (const nil) character))
 
 (defcustom shr-table-vertical-line ?\s
   "Character used to draw vertical table lines."
@@ -90,6 +90,7 @@ used."
 Alternative suggestions are:
 - \"  \"
 - \"  \""
+  :version "24.4"
   :type 'string
   :group 'shr)
 
@@ -99,6 +100,12 @@ Alternative suggestions are:
   :group 'shr
   :type 'function)
 
+(defcustom shr-image-animate t
+  "Non nil means that images that can be animated will be."
+  :version "24.4"
+  :group 'shr
+  :type 'boolean)
+
 (defvar shr-content-function nil
   "If bound, this should be a function that will return the content.
 This is used for cid: URLs, and the function is called with the
@@ -140,8 +147,8 @@ cid: URL as the argument.")
     (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 [tab] 'shr-next-link)
-    (define-key map [backtab] 'shr-previous-link)
+    (define-key map [?\t] 'shr-next-link)
+    (define-key map [?\M-\t] 'shr-previous-link)
     (define-key map [follow-link] 'mouse-face)
     (define-key map [mouse-2] 'shr-browse-url)
     (define-key map "I" 'shr-insert-image)
@@ -168,6 +175,7 @@ cid: URL as the argument.")
      (libxml-parse-html-region (point-min) (point-max))))
   (goto-char (point-min)))
 
+;;;###autoload
 (defun shr-render-region (begin end &optional buffer)
   "Display the HTML rendering of the region between BEGIN and END."
   (interactive "r")
@@ -179,13 +187,6 @@ cid: URL as the argument.")
       (goto-char begin)
       (shr-insert-document dom))))
 
-(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.
@@ -196,7 +197,6 @@ DOM should be a parse tree as generated by
 	(shr-state nil)
 	(shr-start nil)
 	(shr-base nil)
-	(shr-preliminary-table-render 0)
 	(shr-width (or shr-width (1- (window-width)))))
     (shr-descend (shr-transform-dom dom))
     (shr-remove-trailing-whitespace start (point))))
@@ -365,6 +365,14 @@ size, and full-buffer size."
 	(push (shr-transform-dom sub) result)))
     (nreverse result)))
 
+(defsubst shr-generic (cont)
+  (dolist (sub cont)
+    (cond
+     ((eq (car sub) 'text)
+      (shr-insert (cdr sub)))
+     ((listp (cdr sub))
+      (shr-descend sub)))))
+
 (defun shr-descend (dom)
   (let ((function
 	 (or
@@ -380,14 +388,17 @@ size, and full-buffer size."
 	  (setq shr-stylesheet (nconc (shr-parse-style style)
 				      shr-stylesheet))
 	(setq style nil)))
-    ;; If we have a display:none, then just ignore this part of the
-    ;; DOM.
+    ;; If we have a display:none, then just ignore this part of the DOM.
     (unless (equal (cdr (assq 'display shr-stylesheet)) "none")
       (if (fboundp function)
 	  (funcall function (cdr dom))
 	(shr-generic (cdr dom)))
       (when (and shr-target-id
 		 (equal (cdr (assq :id (cdr dom))) shr-target-id))
+	;; If the element was empty, we don't have anything to put the
+	;; anchor on.  So just insert a dummy character.
+	(when (= start (point))
+	  (insert "*"))
 	(put-text-property start (1+ start) 'shr-target-id shr-target-id))
       ;; If style is set, then this node has set the color.
       (when style
@@ -395,14 +406,6 @@ size, and full-buffer size."
 			     (cdr (assq 'color shr-stylesheet))
 			     (cdr (assq 'background-color shr-stylesheet)))))))
 
-(defun shr-generic (cont)
-  (dolist (sub cont)
-    (cond
-     ((eq (car sub) 'text)
-      (shr-insert (cdr sub)))
-     ((listp (cdr sub))
-      (shr-descend sub)))))
-
 (defmacro shr-char-breakable-p (char)
   "Return non-nil if a line can be broken before and after CHAR."
   `(aref fill-find-break-point-function-table ,char))
@@ -416,7 +419,9 @@ size, and full-buffer size."
 ;; of a line or the end of a line.
 (defmacro shr-char-kinsoku-bol-p (char)
   "Return non-nil if a line ought not to begin with CHAR."
-  `(aref (char-category-set ,char) ?>))
+  `(let ((char ,char))
+     (and (not (eq char ?'))
+	  (aref (char-category-set char) ?>))))
 (defmacro shr-char-kinsoku-eol-p (char)
   "Return non-nil if a line ought not to end with CHAR."
   `(aref (char-category-set ,char) ?<))
@@ -463,6 +468,7 @@ size, and full-buffer size."
       (setq shr-state nil)
       (let (found)
 	(while (and (> (current-column) shr-width)
+		    (> shr-width 0)
 		    (progn
 		      (setq found (shr-find-fill-point))
 		      (not (eolp))))
@@ -476,7 +482,13 @@ size, and full-buffer size."
 	  (when (> shr-indentation 0)
 	    (shr-indent))
 	  (end-of-line))
-	(insert " ")))
+	(if (<= (current-column) shr-width)
+	    (insert " ")
+	  ;; In case we couldn't get a valid break point (because of a
+	  ;; word that's longer than `shr-width'), just break anyway.
+	  (insert "\n")
+	  (when (> shr-indentation 0)
+	    (shr-indent)))))
     (unless (string-match "[ \t\r\n ]\\'" text)
       (delete-char -1)))))
 
@@ -485,36 +497,27 @@ size, and full-buffer size."
     (backward-char 1))
   (let ((bp (point))
 	failed)
-    (while (not (or (setq failed (= (current-column) shr-indentation))
+    (while (not (or (setq failed (<= (current-column) shr-indentation))
 		    (eq (preceding-char) ? )
 		    (eq (following-char) ? )
 		    (shr-char-breakable-p (preceding-char))
 		    (shr-char-breakable-p (following-char))
-		    (if (eq (preceding-char) ?')
-			(not (memq (char-after (- (point) 2))
-				   (list nil ?\n ? )))
-		      (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))))
+		    (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))
+		    (bolp)))
       (backward-char 1))
-    (if (and (not (or failed (eolp)))
-	     (eq (preceding-char) ?'))
-	(while (not (or (setq failed (eolp))
-			(eq (following-char) ? )
-			(shr-char-breakable-p (following-char))
-			(shr-char-kinsoku-eol-p (following-char))))
-	  (forward-char 1)))
     (if failed
 	;; There's no breakable point, so we give it up.
 	(let (found)
 	  (goto-char bp)
 	  (unless shr-kinsoku-shorten
-	    (while (and (setq found (re-search-forward
-				     "\\(\\c>\\)\\| \\|\\c<\\|\\c|"
-				     (line-end-position) 'move))
-			(eq (preceding-char) ?')))
-	    (if (and found (not (match-beginning 1)))
+	    (while (setq found (re-search-forward
+				"\\(\\c>\\)\\| \\|\\c<\\|\\c|"
+				(line-end-position) 'move)))
+	    (if (and found
+		     (not (match-beginning 1)))
 		(goto-char (match-beginning 0)))))
       (or
        (eolp)
@@ -525,7 +528,7 @@ size, and full-buffer size."
 	 (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? )))
 		     (shr-char-kinsoku-eol-p (preceding-char)))
 	   (backward-char 1))
-	 (when (setq failed (= (current-column) shr-indentation))
+	 (when (setq failed (<= (current-column) shr-indentation))
 	   ;; There's no breakable point that doesn't violate kinsoku,
 	   ;; so we look for the second best position.
 	   (while (and (progn
@@ -545,12 +548,12 @@ size, and full-buffer size."
 		      (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))))
+	 (when (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))
@@ -607,7 +610,7 @@ size, and full-buffer size."
 	 (concat (nth 3 base) url))
 	(t
 	 ;; Totally relative.
-	 (concat (car base) (cadr base) url))))
+	 (concat (car base) (expand-file-name url (cadr base))))))
 
 (defun shr-ensure-newline ()
   (unless (zerop (current-column))
@@ -705,7 +708,7 @@ If EXTERNAL, browse the URL using `shr-external-browser'."
       (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))))
+	(let ((data (shr-parse-image-data)))
 	  (with-current-buffer buffer
 	    (save-excursion
 	      (let ((alt (buffer-substring start end))
@@ -732,20 +735,32 @@ If EXTERNAL, browse the URL using `shr-external-browser'."
 	(setq payload (base64-decode-string payload)))
       payload)))
 
-(defun shr-put-image (data alt &optional flags)
-  "Put image DATA with a string ALT.  Return image."
+;; Behind display-graphic-p test.
+(declare-function image-size "image.c" (spec &optional pixels frame))
+(declare-function image-animate "image" (image &optional index limit))
+
+(defun shr-put-image (spec alt &optional flags)
+  "Insert image SPEC with a string ALT.  Return image.
+SPEC is either an image data blob, or a list where the first
+element is the data blob and the second element is the content-type."
   (if (display-graphic-p)
       (let* ((size (cdr (assq 'size flags)))
+	     (data (if (consp spec)
+		       (car spec)
+		     spec))
+	     (content-type (and (consp spec)
+				(cadr spec)))
 	     (start (point))
 	     (image (cond
 		     ((eq size 'original)
-		      (create-image data nil t :ascent 100))
+		      (create-image data nil t :ascent 100
+				    :format content-type))
 		     ((eq size 'full)
 		      (ignore-errors
-			(shr-rescale-image data t)))
+			(shr-rescale-image data content-type)))
 		     (t
 		      (ignore-errors
-			(shr-rescale-image data))))))
+			(shr-rescale-image data content-type))))))
         (when image
 	  ;; When inserting big-ish pictures, put them at the
 	  ;; beginning of the line.
@@ -756,23 +771,22 @@ If EXTERNAL, browse the URL using `shr-external-browser'."
 	      (insert-sliced-image image (or alt "*") nil 20 1)
 	    (insert-image image (or alt "*")))
 	  (put-text-property start (point) 'image-size size)
-	  (when (cond ((fboundp 'image-multi-frame-p)
+	  (when (and shr-image-animate
+                     (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)))
+                            (cdr (image-multi-frame-p image)))
+                           ((fboundp 'image-animated-p)
+                            (image-animated-p image))))
+            (image-animate image nil 60)))
 	image)
     (insert alt)))
 
-(defun shr-rescale-image (data &optional force)
-  "Rescale DATA, if too big, to fit the current buffer.
-If FORCE, rescale the image anyway."
-  (if (or (not (fboundp 'imagemagick-types))
-	  (eq (image-type-from-data data) 'gif)
-	  (not (get-buffer-window (current-buffer))))
+(defun shr-rescale-image (data &optional content-type)
+  "Rescale DATA, if too big, to fit the current buffer."
+  (if (not (and (fboundp 'imagemagick-types)
+                (get-buffer-window (current-buffer))))
       (create-image data nil t :ascent 100)
     (let ((edges (window-inside-pixel-edges
 		  (get-buffer-window (current-buffer)))))
@@ -782,7 +796,8 @@ If FORCE, rescale the image anyway."
        :max-width (truncate (* shr-max-image-proportion
 			       (- (nth 2 edges) (nth 0 edges))))
        :max-height (truncate (* shr-max-image-proportion
-				(- (nth 3 edges) (nth 1 edges))))))))
+				(- (nth 3 edges) (nth 1 edges))))
+       :format content-type))))
 
 ;; url-cache-extract autoloads url-cache.
 (declare-function url-cache-create-filename "url-cache" (url))
@@ -799,7 +814,17 @@ Return a string with image data."
 	    t)
       (when (or (search-forward "\n\n" nil t)
 		(search-forward "\r\n\r\n" nil t))
-	(buffer-substring (point) (point-max))))))
+	(shr-parse-image-data)))))
+
+(defun shr-parse-image-data ()
+  (list
+   (buffer-substring (point) (point-max))
+   (save-excursion
+     (save-restriction
+       (narrow-to-region (point-min) (point))
+       (let ((content-type (mail-fetch-field "content-type")))
+	 (and content-type
+	      (intern content-type obarray)))))))
 
 (defun shr-image-displayer (content-function)
   "Return a function to display an image.
@@ -827,7 +852,6 @@ START, and END.  Note that START and END should be markers."
   (shr-ensure-paragraph))
 
 (defun shr-urlify (start url &optional title)
-  (when (and title (string-match "ctx" title)) (debug))
   (shr-add-font start (point) 'shr-link)
   (add-text-properties
    start (point)
@@ -943,23 +967,30 @@ 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-style (_cont)
   )
 
-(defun shr-tag-script (cont)
+(defun shr-tag-script (_cont)
   )
 
-(defun shr-tag-comment (cont)
+(defun shr-tag-comment (_cont)
   )
 
 (defun shr-dom-to-xml (dom)
   "Convert DOM into a string containing the xml representation."
   (let ((arg " ")
-        (text ""))
+        (text "")
+	url)
     (dolist (sub (cdr dom))
       (cond
        ((listp (cdr sub))
-        (setq text (concat text (shr-dom-to-xml sub))))
+	;; Ignore external image definitions if required.
+	;; <image xlink:href="http://TRACKING_URL/"/>
+	(when (or (not (eq (car sub) 'image))
+		  (not (setq url (cdr (assq ':xlink:href (cdr sub)))))
+		  (not shr-blocked-images)
+		  (not (string-match shr-blocked-images url)))
+	  (setq text (concat text (shr-dom-to-xml sub)))))
        ((eq (car sub) 'text)
         (setq text (concat text (cdr sub))))
        (t
@@ -973,7 +1004,8 @@ ones, in case fg and bg are nil."
             (car dom))))
 
 (defun shr-tag-svg (cont)
-  (when (image-type-available-p 'svg)
+  (when (and (image-type-available-p 'svg)
+	     (not shr-inhibit-images))
     (funcall shr-put-image-function
              (shr-dom-to-xml (cons 'svg cont))
              "SVG Image")))
@@ -1057,6 +1089,14 @@ ones, in case fg and bg are nil."
 	(start (point))
 	shr-start)
     (shr-generic cont)
+    (when (and shr-target-id
+	       (equal (cdr (assq :name cont)) shr-target-id))
+      ;; We have a zero-length <a name="foo"> element, so just
+      ;; insert...  something.
+      (when (= start (point))
+	(shr-ensure-newline)
+	(insert " "))
+      (put-text-property start (1+ start) 'shr-target-id shr-target-id))
     (when (and url
 	       (not shr-inhibit-decoration))
       (shr-urlify (or shr-start start) (shr-expand-url url) title))))
@@ -1075,17 +1115,79 @@ ones, in case fg and bg are nil."
       (shr-urlify start (shr-expand-url url)))
     (shr-generic cont)))
 
+(defcustom shr-prefer-media-type-alist '(("webm" . 1.0)
+                                         ("ogv"  . 1.0)
+                                         ("ogg"  . 1.0)
+                                         ("opus" . 1.0)
+                                         ("flac" . 0.9)
+                                         ("wav"  . 0.5))
+  "Preferences for media types.
+The key element should be a regexp matched against the type of the source or
+url if no type is specified.  The value should be a float in the range 0.0 to
+1.0.  Media elements with higher value are preferred."
+  :version "24.4"
+  :group 'shr
+  :type '(alist :key-type regexp :value-type float))
+
+(defun shr--get-media-pref (elem)
+  "Determine the preference for ELEM.
+The preference is a float determined from `shr-prefer-media-type'."
+  (let ((type (cdr (assq :type elem)))
+        (p 0.0))
+    (unless type
+      (setq type (cdr (assq :src elem))))
+    (when type
+      (dolist (pref shr-prefer-media-type-alist)
+        (when (and
+               (> (cdr pref) p)
+               (string-match-p (car pref) type))
+          (setq p (cdr pref)))))
+    p))
+
+(defun shr--extract-best-source (cont &optional url pref)
+  "Extract the best `:src' property from <source> blocks in CONT."
+  (setq pref (or pref -1.0))
+  (let (new-pref)
+    (dolist (elem cont)
+      (when (and (eq (car elem) 'source)
+		 (< pref
+		    (setq new-pref
+			  (shr--get-media-pref elem))))
+	(setq pref new-pref
+	      url (cdr (assq :src elem)))
+        ;; libxml's html parser isn't HTML5 compliant and non terminated
+        ;; source tags might end up as children.  So recursion it is...
+        (dolist (child (cdr elem))
+          (when (eq (car child) 'source)
+            (let ((ret (shr--extract-best-source (list child) url pref)))
+              (when (< pref (cdr ret))
+                (setq url (car ret)
+                      pref (cdr ret)))))))))
+  (cons url pref))
+
 (defun shr-tag-video (cont)
   (let ((image (cdr (assq :poster cont)))
-	(url (cdr (assq :src cont)))
-	(start (point)))
-    (shr-tag-img nil image)
+        (url (cdr (assq :src cont)))
+        (start (point)))
+    (unless url
+      (setq url (car (shr--extract-best-source cont))))
+    (if image
+        (shr-tag-img nil image)
+      (shr-insert " [video] "))
+    (shr-urlify start (shr-expand-url url))))
+
+(defun shr-tag-audio (cont)
+  (let ((url (cdr (assq :src cont)))
+        (start (point)))
+    (unless url
+      (setq url (car (shr--extract-best-source cont))))
+    (shr-insert " [audio] ")
     (shr-urlify start (shr-expand-url url))))
 
 (defun shr-tag-img (cont &optional url)
   (when (or url
 	    (and cont
-		 (cdr (assq :src cont))))
+		 (> (length (cdr (assq :src cont))) 0)))
     (when (and (> (current-column) 0)
 	       (not (eq shr-state 'image)))
       (insert "\n"))
@@ -1141,7 +1243,9 @@ ones, in case fg and bg are nil."
 	  (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))
+	  (put-text-property start (point) 'help-echo
+			     (or (cdr (assq :title cont))
+				 alt)))
 	(setq shr-state 'image)))))
 
 (defun shr-tag-pre (cont)
@@ -1230,7 +1334,7 @@ ones, in case fg and bg are nil."
 (defun shr-tag-h6 (cont)
   (shr-heading cont))
 
-(defun shr-tag-hr (cont)
+(defun shr-tag-hr (_cont)
   (shr-ensure-newline)
   (insert (make-string shr-width shr-hr-line) "\n"))
 
@@ -1311,7 +1415,7 @@ ones, in case fg and bg are nil."
 	(if caption `((tr (td ,@caption))))
 	(if header
 	    (if footer
-		;; hader + body + footer
+		;; header + body + footer
 		(if (= nheader nbody)
 		    (if (= nbody nfooter)
 			`((tr (td (table (tbody ,@header ,@body ,@footer)))))
@@ -1488,7 +1592,11 @@ ones, in case fg and bg are nil."
 		      10))
 	      (when (and fill
 			 (setq colspan (cdr (assq :colspan (cdr column)))))
-		(setq colspan (string-to-number colspan))
+		(setq colspan (min (string-to-number colspan)
+				   ;; The colspan may be wrong, so
+				   ;; truncate it to the length of the
+				   ;; remaining columns.
+				   (- (length widths) i)))
 		(dotimes (j (1- colspan))
 		  (if (> (+ i 1 j) (1- (length widths)))
 		      (setq width (aref widths (1- (length widths))))
@@ -1498,9 +1606,6 @@ ones, in case fg and bg are nil."
 		(setq width-column (+ width-column (1- colspan))))
 	      (when (or column
 			(not fill))
-		;; Sanity check for degenerate tables.
-		(when (zerop width)
-		  (setq width 10))
 		(push (shr-render-td (cdr column) width fill)
 		      tds))
 	      (setq i (1+ i)
@@ -1509,7 +1614,6 @@ ones, in case fg and bg are nil."
     (nreverse trs)))
 
 (defun shr-render-td (cont width fill)
-  (when (= width 0) (debug))
   (with-temp-buffer
     (let ((bgcolor (cdr (assq :bgcolor cont)))
 	  (fgcolor (cdr (assq :fgcolor cont)))