[Emacs-diffs] /srv/bzr/emacs/trunk r103964: shr.el (shr-base): New binding.

[Katsumi Yamaoka]

------------------------------------------------------------
revno: 103964
author: Lars Magne Ingebrigtsen <address@hidden>
committer: Katsumi Yamaoka <address@hidden>
branch nick: trunk
timestamp: Thu 2011-04-21 00:24:27 +0000
message:
  shr.el (shr-base): New binding.
   (shr-tag-base): Keep track of <base>.
   (shr-expand-url): New function used throughout.
modified:
  lisp/gnus/ChangeLog
  lisp/gnus/shr.el

=== modified file 'lisp/gnus/ChangeLog'
--- a/lisp/gnus/ChangeLog       2011-04-20 22:12:08 +0000
+++ b/lisp/gnus/ChangeLog       2011-04-21 00:24:27 +0000
@@ -1,3 +1,9 @@
+2011-04-20  Lars Magne Ingebrigtsen  <address@hidden>
+
+       * 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  <address@hidden>
 
        * gnus-registry.el

=== modified file 'lisp/gnus/shr.el'
--- a/lisp/gnus/shr.el  2011-03-18 13:45:04 +0000
+++ b/lisp/gnus/shr.el  2011-04-21 00:24:27 +0000
@@ -99,6 +99,7 @@
 (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 @@
   (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 @@
         (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 @@
                    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 @@
        (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 @@
        (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 @@
               (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 "*"))