Add support for SVG images

[gnus] / lisp / shr.el

diff --git a/lisp/shr.el b/lisp/shr.el
index 293ba24..5173908 100644 (file)
--- a/lisp/shr.el
+++ b/lisp/shr.el
@@ -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."
@@ -114,6 +114,7 @@ cid: URL as the argument.")
 (defvar shr-stylesheet nil)
 (defvar shr-base nil)
 (defvar shr-ignore-cache nil)
+(defvar shr-external-rendering-functions nil)
 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))
@@ -156,6 +157,7 @@ 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 (window-width))))
     (shr-descend (shr-transform-dom dom))
     (shr-remove-trailing-whitespace start (point))))
@@ -291,7 +293,12 @@ size, and full-buffer size."
     (nreverse result)))
 
 (defun shr-descend (dom)
-  (let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))
+  (let ((function
+        (or
+         ;; Allow other packages to override (or provide) rendering
+         ;; of elements.
+         (cdr (assq (car dom) shr-external-rendering-functions))
+         (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)))
        (style (cdr (assq :style (cdr dom))))
        (shr-stylesheet shr-stylesheet)
        (start (point)))
@@ -477,21 +484,42 @@ size, and full-buffer size."
         (forward-char 1))))
     (not failed)))
 
-(defun shr-expand-url (url)
-  (cond
-   ;; Absolute URL.
-   ((or (not url)
-       (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))
-   (t
-    (concat shr-base url))))
+(defun shr-parse-base (url)
+  (let* ((parsed (url-generic-parse-url url))
+        (local (url-filename parsed)))
+    (setf (url-filename parsed) "")
+    ;; Chop off the bit after the last slash.
+    (when (string-match "\\`\\(.*/\\)[^/]+\\'" local)
+      (setq local (match-string 1 local)))
+    ;; Always make the local bit end with a slash.
+    (when (and (not (zerop (length local)))
+              (not (eq (aref local (1- (length local))) ?/)))
+      (setq local (concat local "/")))
+    (list (url-recreate-url parsed)
+         local
+         (url-type parsed))))
+
+(defun shr-expand-url (url &optional base)
+  (setq base
+       (if base
+           (shr-parse-base base)
+         ;; Bound by the parser.
+         shr-base))
+  (cond ((or (not url)
+            (not base)
+            (string-match "\\`[a-z]*:" url))
+        ;; Absolute URL.
+        (or url (car base)))
+       ((eq (aref url 0) ?/)
+        (if (and (> (length url) 1)
+                 (eq (aref url 1) ?/))
+            ;; //host...; just use the protocol
+            (concat (nth 2 base) ":" url)
+          ;; Just use the host name part.
+          (concat (car base) url)))
+       (t
+        ;; Totally relative.
+        (concat (car base) (cadr base) url))))
 
 (defun shr-ensure-newline ()
   (unless (zerop (current-column))
@@ -631,12 +659,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 (if (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))
-                 (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)))
@@ -876,6 +905,32 @@ ones, in case fg and bg are nil."
 (defun shr-tag-comment (cont)
   )
 
+(defun shr-dom-to-xml (dom)
+  "Convert DOM into a string containing the xml representation."
+  (let ((arg " ")
+        (text ""))
+    (dolist (sub (cdr dom))
+      (cond
+       ((listp (cdr sub))
+        (setq text (concat text (dom-to-text sub))))
+       ((eq (car sub) 'text)
+        (setq text (concat text (cdr sub))))
+       (t
+        (setq arg (concat arg (format "%s=\"%s\" "
+                                      (substring (symbol-name (car sub)) 1)
+                                      (cdr sub)))))))
+    (format "<%s%s>%s</%s>"
+            (car dom)
+            (substring arg 0 (1- (length arg)))
+            text
+            (car dom))))
+
+(defun shr-tag-svg (cont)
+  (when (image-type-available-p 'svg)
+    (funcall shr-put-image-function
+             (shr-dom-to-xml (cons 'svg cont))
+             "SVG Image")))
+
 (defun shr-tag-sup (cont)
   (let ((start (point)))
     (shr-generic cont)
@@ -944,7 +999,8 @@ ones, in case fg and bg are nil."
       plist)))
 
 (defun shr-tag-base (cont)
-  (setq shr-base (cdr (assq :href cont))))
+  (setq shr-base (shr-parse-base (cdr (assq :href cont))))
+  (shr-generic cont))
 
 (defun shr-tag-a (cont)
   (let ((url (cdr (assq :href cont)))
@@ -1088,6 +1144,14 @@ ones, in case fg and bg are nil."
     (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))