X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fshr.el;h=acda83fbdf7295427f0e69affde30d367a375335;hb=ac910f70b3eab14b9341e9214cb0a5a5f3c218b6;hp=ff8c918b7e8e96d2e92077d564169233a593cdf1;hpb=c51a478e5206246505408b920b26fd998cd2bb7c;p=gnus

diff --git a/lisp/shr.el b/lisp/shr.el
index ff8c918b7..acda83fbd 100644
--- a/lisp/shr.el
+++ b/lisp/shr.el
@@ -55,8 +55,9 @@ fit these criteria."
   :group 'shr
   :type '(choice (const nil) regexp))
 
-(defcustom shr-table-horizontal-line ?\s
-  "Character used to draw horizontal table lines."
+(defcustom shr-table-horizontal-line nil
+  "Character used to draw horizontal table lines.
+If nil, don't draw horizontal table lines."
   :group 'shr
   :type 'character)
 
@@ -125,6 +126,8 @@ cid: URL as the argument.")
 (defvar shr-ignore-cache nil)
 (defvar shr-external-rendering-functions nil)
 (defvar shr-target-id nil)
+(defvar shr-inhibit-decoration nil)
+(defvar shr-table-separator-length 1)
 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))
@@ -133,6 +136,7 @@ cid: URL as the argument.")
     (define-key map "z" 'shr-zoom-image)
     (define-key map [tab] 'shr-next-link)
     (define-key map [backtab] 'shr-previous-link)
+    (define-key map [follow-link] 'mouse-face)
     (define-key map "I" 'shr-insert-image)
     (define-key map "u" 'shr-copy-url)
     (define-key map "v" 'shr-browse-url)
@@ -141,10 +145,14 @@ cid: URL as the argument.")
     map))
 
 ;; Public functions and commands.
+(declare-function libxml-parse-html-region "xml.c"
+		  (start end &optional base-url))
 
 (defun shr-render-buffer (buffer)
   "Display the HTML rendering of the current buffer."
   (interactive (list (current-buffer)))
+  (or (fboundp 'libxml-parse-html-region)
+      (error "This function requires Emacs to be compiled with libxml2"))
   (pop-to-buffer "*html*")
   (erase-buffer)
   (shr-insert-document
@@ -170,7 +178,7 @@ DOM should be a parse tree as generated by
 	(shr-start nil)
 	(shr-base nil)
 	(shr-preliminary-table-render 0)
-	(shr-width (or shr-width (window-width))))
+	(shr-width (or shr-width (1- (window-width)))))
     (shr-descend (shr-transform-dom dom))
     (shr-remove-trailing-whitespace start (point))))
 
@@ -222,9 +230,9 @@ redirects somewhere else."
 (defun shr-next-link ()
   "Skip to the next link."
   (interactive)
-  (let ((skip (text-property-any (point) (point-max) 'shr-url nil)))
+  (let ((skip (text-property-any (point) (point-max) 'help-echo nil)))
     (if (not (setq skip (text-property-not-all skip (point-max)
-					       'shr-url nil)))
+					       'help-echo nil)))
 	(message "No next link")
       (goto-char skip)
       (message "%s" (get-text-property (point) 'help-echo)))))
@@ -236,11 +244,11 @@ redirects somewhere else."
 	(found nil))
     ;; Skip past the current link.
     (while (and (not (bobp))
-		(get-text-property (point) 'shr-url))
+		(get-text-property (point) 'help-echo))
       (forward-char -1))
     ;; Find the previous link.
     (while (and (not (bobp))
-		(not (setq found (get-text-property (point) 'shr-url))))
+		(not (setq found (get-text-property (point) 'help-echo))))
       (forward-char -1))
     (if (not found)
 	(progn
@@ -248,7 +256,7 @@ redirects somewhere else."
 	  (goto-char start))
       ;; Put point at the start of the link.
       (while (and (not (bobp))
-		  (get-text-property (point) 'shr-url))
+		  (get-text-property (point) 'help-echo))
 	(forward-char -1))
       (forward-char 1)
       (message "%s" (get-text-property (point) 'help-echo)))))
@@ -349,7 +357,7 @@ size, and full-buffer size."
 	(shr-stylesheet shr-stylesheet)
 	(start (point)))
     (when style
-      (if (string-match "color\\|display" style)
+      (if (string-match "color\\|display\\|border-collapse" style)
 	  (setq shr-stylesheet (nconc (shr-parse-style style)
 				      shr-stylesheet))
 	(setq style nil)))
@@ -595,7 +603,14 @@ size, and full-buffer size."
 	  (insert "\n"))
       (if (save-excursion
 	    (beginning-of-line)
-	    (looking-at " *$"))
+	    ;; If the current line is totally blank, and doesn't even
+	    ;; have any face properties set, then delete the blank
+	    ;; space.
+	    (and (looking-at " *$")
+		 (not (get-text-property (point) 'face))
+		 (not (= (next-single-property-change (point) 'face nil
+						      (line-end-position))
+			 (line-end-position)))))
 	  (delete-region (match-beginning 0) (match-end 0))
 	(insert "\n\n")))))
 
@@ -609,24 +624,20 @@ 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 face to 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.
 (defun shr-add-font (start end type)
-  (save-excursion
-    (goto-char start)
-    (while (< (point) end)
-      (when (bolp)
-	(skip-chars-forward " "))
-      (add-face-text-property (point) (min (line-end-position) end) type t)
-      (if (< (line-end-position) end)
-	  (forward-line 1)
-	(goto-char end)))))
+  (unless shr-inhibit-decoration
+    (save-excursion
+      (goto-char start)
+      (while (< (point) end)
+	(when (bolp)
+	  (skip-chars-forward " "))
+	(add-face-text-property (point) (min (line-end-position) end) type t)
+	(if (< (line-end-position) end)
+	    (forward-line 1)
+	  (goto-char end))))))
 
 (defun shr-browse-url ()
   "Browse the URL under point."
@@ -802,12 +813,13 @@ 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)
    (list 'shr-url url
-	 'local-map shr-map
-	 'help-echo (if title (format "%s (%s)" url title) url))))
+	 'help-echo (if title (format "%s (%s)" url title) url)
+	 'keymap shr-map)))
 
 (defun shr-encode-url (url)
   "Encode URL."
@@ -839,13 +851,18 @@ ones, in case fg and bg are nil."
                (shr-color-visible bg fg)))))))
 
 (defun shr-colorize-region (start end fg &optional bg)
-  (when (or fg bg)
+  (when (and (not shr-inhibit-decoration)
+	     (or fg bg))
     (let ((new-colors (shr-color-check fg bg)))
       (when new-colors
 	(when fg
-	  (shr-add-font start end (list :foreground (cadr new-colors))))
+	  (add-face-text-property start end
+				  (list :foreground (cadr new-colors))
+				  t))
 	(when bg
-	  (shr-add-font start end (list :background (car new-colors)))))
+	  (add-face-text-property start end
+				  (list :background (car new-colors))
+				  t)))
       new-colors)))
 
 (defun shr-expand-newlines (start end color)
@@ -1013,7 +1030,9 @@ ones, in case fg and bg are nil."
       plist)))
 
 (defun shr-tag-base (cont)
-  (setq shr-base (shr-parse-base (cdr (assq :href cont))))
+  (let ((base (cdr (assq :href cont))))
+    (when base
+      (setq shr-base (shr-parse-base base))))
   (shr-generic cont))
 
 (defun shr-tag-a (cont)
@@ -1022,7 +1041,8 @@ ones, in case fg and bg are nil."
 	(start (point))
 	shr-start)
     (shr-generic cont)
-    (when url
+    (when (and url
+	       (not shr-inhibit-decoration))
       (shr-urlify (or shr-start start) (shr-expand-url url) title))))
 
 (defun shr-tag-object (cont)
@@ -1122,6 +1142,21 @@ ones, in case fg and bg are nil."
     (shr-generic cont))
   (shr-ensure-paragraph))
 
+(defun shr-tag-dl (cont)
+  (shr-ensure-paragraph)
+  (shr-generic cont)
+  (shr-ensure-paragraph))
+
+(defun shr-tag-dt (cont)
+  (shr-ensure-newline)
+  (shr-generic cont)
+  (shr-ensure-newline))
+
+(defun shr-tag-dd (cont)
+  (shr-ensure-newline)
+  (let ((shr-indentation (+ shr-indentation 4)))
+    (shr-generic cont)))
+
 (defun shr-tag-ul (cont)
   (shr-ensure-paragraph)
   (let ((shr-list-mode 'ul))
@@ -1159,11 +1194,7 @@ ones, in case fg and bg are nil."
   (shr-generic cont))
 
 (defun shr-tag-span (cont)
-  (let ((title (cdr (assq :title cont))))
-    (shr-generic cont)
-    (when (and title
-	       shr-start)
-      (put-text-property shr-start (point) 'help-echo title))))
+  (shr-generic cont))
 
 (defun shr-tag-h1 (cont)
   (shr-heading cont 'bold 'underline))
@@ -1235,13 +1266,7 @@ ones, in case fg and bg are nil."
 	     (frame-width))
       (setq truncate-lines t))
     ;; Then render the table again with these new "hard" widths.
-    (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths))
-  ;; Finally, insert all the images after the table.  The Emacs buffer
-  ;; model isn't strong enough to allow us to put the images actually
-  ;; into the tables.
-  (when (zerop shr-table-depth)
-    (dolist (elem (shr-find-elements cont 'img))
-      (shr-tag-img (cdr elem)))))
+    (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths)))
 
 (defun shr-tag-table (cont)
   (shr-ensure-paragraph)
@@ -1305,7 +1330,13 @@ ones, in case fg and bg are nil."
 	      body))))))
     (when bgcolor
       (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
-			   bgcolor))))
+			   bgcolor))
+    ;; Finally, insert all the images after the table.  The Emacs buffer
+    ;; model isn't strong enough to allow us to put the images actually
+    ;; into the tables.
+    (when (zerop shr-table-depth)
+      (dolist (elem (shr-find-elements cont 'img))
+	(shr-tag-img (cdr elem))))))
 
 (defun shr-find-elements (cont type)
   (let (result)
@@ -1317,45 +1348,52 @@ ones, in case fg and bg are nil."
     (nreverse result)))
 
 (defun shr-insert-table (table widths)
-  (shr-insert-table-ruler widths)
-  (dolist (row table)
-    (let ((start (point))
-	  (height (let ((max 0))
-		    (dolist (column row)
-		      (setq max (max max (cadr column))))
-		    max)))
-      (dotimes (i height)
-	(shr-indent)
-	(insert shr-table-vertical-line "\n"))
-      (dolist (column row)
-	(goto-char start)
-	(let ((lines (nth 2 column)))
-	  (dolist (line lines)
-	    (end-of-line)
-	    (insert line shr-table-vertical-line)
-	    (forward-line 1))
-	  ;; Add blank lines at padding at the bottom of the TD,
-	  ;; possibly.
-	  (dotimes (i (- height (length lines)))
-	    (end-of-line)
-	    (let ((start (point)))
-	      (insert (make-string (string-width (car lines)) ? )
-		      shr-table-vertical-line)
-	      (when (nth 4 column)
-		(shr-add-font start (1- (point))
-			      (list :background (nth 4 column)))))
-	    (forward-line 1)))))
-    (shr-insert-table-ruler widths)))
+  (let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
+			  "collapse"))
+	 (shr-table-separator-length (if collapse 0 1))
+	 (shr-table-vertical-line (if collapse "" shr-table-vertical-line)))
+    (unless collapse
+      (shr-insert-table-ruler widths))
+    (dolist (row table)
+      (let ((start (point))
+	    (height (let ((max 0))
+		      (dolist (column row)
+			(setq max (max max (cadr column))))
+		      max)))
+	(dotimes (i height)
+	  (shr-indent)
+	  (insert shr-table-vertical-line "\n"))
+	(dolist (column row)
+	  (goto-char start)
+	  (let ((lines (nth 2 column)))
+	    (dolist (line lines)
+	      (end-of-line)
+	      (insert line shr-table-vertical-line)
+	      (forward-line 1))
+	    ;; Add blank lines at padding at the bottom of the TD,
+	    ;; possibly.
+	    (dotimes (i (- height (length lines)))
+	      (end-of-line)
+	      (let ((start (point)))
+		(insert (make-string (string-width (car lines)) ? )
+			shr-table-vertical-line)
+		(when (nth 4 column)
+		  (shr-add-font start (1- (point))
+				(list :background (nth 4 column)))))
+	      (forward-line 1)))))
+      (unless collapse
+	(shr-insert-table-ruler widths)))))
 
 (defun shr-insert-table-ruler (widths)
-  (when (and (bolp)
-	     (> shr-indentation 0))
-    (shr-indent))
-  (insert shr-table-corner)
-  (dotimes (i (length widths))
-    (insert (make-string (aref widths i) shr-table-horizontal-line)
-	    shr-table-corner))
-  (insert "\n"))
+  (when shr-table-horizontal-line
+    (when (and (bolp)
+	       (> shr-indentation 0))
+      (shr-indent))
+    (insert shr-table-corner)
+    (dotimes (i (length widths))
+      (insert (make-string (aref widths i) shr-table-horizontal-line)
+	      shr-table-corner))
+    (insert "\n")))
 
 (defun shr-table-widths (table natural-table suggested-widths)
   (let* ((length (length suggested-widths))
@@ -1398,20 +1436,53 @@ ones, in case fg and bg are nil."
 	data)))
 
 (defun shr-make-table-1 (cont widths &optional fill)
-  (let ((trs nil))
+  (let ((trs nil)
+	(shr-inhibit-decoration (not fill))
+	(rowspans (make-vector (length widths) 0))
+	width colspan)
     (dolist (row cont)
       (when (eq (car row) 'tr)
 	(let ((tds nil)
 	      (columns (cdr row))
 	      (i 0)
+	      (width-column 0)
 	      column)
 	  (while (< i (length widths))
-	    (setq column (pop columns))
+	    ;; If we previously had a rowspan definition, then that
+	    ;; means that we now have a "missing" td/th element here.
+	    ;; So just insert a dummy, empty one to (sort of) emulate
+	    ;; rowspan.
+	    (setq column
+		  (if (zerop (aref rowspans i))
+		      (pop columns)
+		    (aset rowspans i (1- (aref rowspans i)))
+		    '(td)))
 	    (when (or (memq (car column) '(td th))
-		      (null column))
-	      (push (shr-render-td (cdr column) (aref widths i) fill)
-		    tds)
-	      (setq i (1+ i))))
+		      (not column))
+	      (when (cdr (assq :rowspan (cdr column)))
+		(aset rowspans i (+ (aref rowspans i)
+				    (1- (string-to-number
+					 (cdr (assq :rowspan (cdr column))))))))
+	      (setq width
+		    (if column
+			(aref widths width-column)
+		      0))
+	      (when (and fill
+			 (setq colspan (cdr (assq :colspan (cdr column)))))
+		(setq colspan (string-to-number colspan))
+		(dotimes (j (1- colspan))
+		  (if (> (+ i 1 j) (1- (length widths)))
+		      (setq width (aref widths (1- (length widths))))
+		    (setq width (+ width
+				   shr-table-separator-length
+				   (aref widths (+ i 1 j))))))
+		(setq width-column (+ width-column (1- colspan))))
+	      (when (or column
+			(not fill))
+		(push (shr-render-td (cdr column) width fill)
+		      tds))
+	      (setq i (1+ i)
+		    width-column (1+ width-column))))
 	  (push (nreverse tds) trs))))
     (nreverse trs)))
 
@@ -1454,11 +1525,23 @@ ones, in case fg and bg are nil."
 	  (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)))
+	    (let ((align (cdr (assq :align cont)))
+		  length)
+	      (while (not (eobp))
+		(end-of-line)
+		(setq length (- width (current-column)))
+		(when (> length 0)
+		  (cond
+		   ((equal align "right")
+		    (beginning-of-line)
+		    (insert (make-string length ? )))
+		   ((equal align "center")
+		    (insert (make-string (/ length 2) ? ))
+		    (beginning-of-line)
+		    (insert (make-string (- length (/ length 2)) ? )))
+		   (t
+		    (insert (make-string length ? )))))
+		(forward-line 1))))
 	  (when style
 	    (setq actual-colors
 		  (shr-colorize-region