shr.el (shr-base): New binding.

 (shr-tag-base): Keep track of <base>.
 (shr-expand-url): New function used throughout.

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 73e7345e07dc56e8446107ef3f4d10127f006a08..9c37b9bf576c9e15f4155bba5b1c831d8bf2165f 100644 (file)
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,9 @@
+2011-04-20  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+       * shr.el (shr-base): New binding.
+       (shr-tag-base): Keep track of <base>.
+       (shr-expand-url): New function used throughout.
+
 2011-04-20  Teodor Zlatanov  <tzz@lifelogs.com>
 
        * gnus-registry.el

diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el
index 113137a0046aaf7e7a77c22ade7948ded4036726..f27705e0bf5bea855756c6a6cac8970f9d86b2a8 100644 (file)
--- a/lisp/gnus/shr.el
+++ b/lisp/gnus/shr.el
@@ -99,6 +99,7 @@ cid: URL as the argument.")
 (defvar shr-kinsoku-shorten nil)
 (defvar shr-table-depth 0)
 (defvar shr-stylesheet nil)
+(defvar shr-base nil)
 
 (defvar shr-map
   (let ((map (make-sparse-keymap)))
@@ -127,6 +128,7 @@ cid: URL as the argument.")
   (setq shr-content-cache nil)
   (let ((shr-state nil)
        (shr-start nil)
+       (shr-base nil)
        (shr-width (or shr-width (window-width))))
     (shr-descend (shr-transform-dom dom))))
 
@@ -392,6 +394,18 @@ redirects somewhere else."
         (forward-char 1))))
     (not failed)))
 
+(defun shr-expand-url (url)
+  (cond
+   ;; Absolute URL.
+   ((or (string-match "\\`[a-z]*:" url)
+       (not shr-base))
+    url)
+   ((and (not (string-match "/\\'" shr-base))
+        (not (string-match "\\`" url)))
+    (concat shr-base "/" url))
+   (t
+    (concat shr-base url))))
+
 (defun shr-ensure-newline ()
   (unless (zerop (current-column))
     (insert "\n")))
@@ -773,13 +787,16 @@ ones, in case fg and bg are nil."
                    plist)))))
       plist)))
 
+(defun shr-tag-base (cont)
+  (setq shr-base (cdr (assq :href cont))))
+
 (defun shr-tag-a (cont)
   (let ((url (cdr (assq :href cont)))
         (title (cdr (assq :title cont)))
        (start (point))
        shr-start)
     (shr-generic cont)
-    (shr-urlify (or shr-start start) url title)))
+    (shr-urlify (or shr-start start) (shr-expand-url url) title)))
 
 (defun shr-tag-object (cont)
   (let ((start (point))
@@ -792,7 +809,7 @@ ones, in case fg and bg are nil."
        (setq url (or url (cdr (assq :value (cdr elem)))))))
     (when url
       (shr-insert " [multimedia] ")
-      (shr-urlify start url))
+      (shr-urlify start (shr-expand-url url)))
     (shr-generic cont)))
 
 (defun shr-tag-video (cont)
@@ -800,7 +817,7 @@ ones, in case fg and bg are nil."
        (url (cdr (assq :src cont)))
        (start (point)))
     (shr-tag-img nil image)
-    (shr-urlify start url)))
+    (shr-urlify start (shr-expand-url url))))
 
 (defun shr-tag-img (cont &optional url)
   (when (or url
@@ -810,7 +827,7 @@ ones, in case fg and bg are nil."
               (not (eq shr-state 'image)))
       (insert "\n"))
     (let ((alt (cdr (assq :alt cont)))
-         (url (or url (cdr (assq :src cont)))))
+         (url (shr-expand-url (or url (cdr (assq :src cont))))))
       (let ((start (point-marker)))
        (when (zerop (length alt))
          (setq alt "*"))