Add support for a default base URI.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 9eb5d0accc404057c63be488cba4e73ad11fa383..9cf8bbb66b5c162e25b0cf034657d6b10d8de9a4 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5415,6 +5415,7 @@ USA.
          make-uri
          make-uri-authority
          merge-uris
+         param:base-uri
          parse-absolute-uri
          parse-partial-absolute-uri
          parse-partial-uri

diff --git a/src/runtime/url.scm b/src/runtime/url.scm
index 5803027f86464e2dd4f5a8c4ea4d7aa1a4f485c7..5606a78b61ccec85c8aca7f92762ea2c2ee6074a 100644 (file)
--- a/src/runtime/url.scm
+++ b/src/runtime/url.scm
@@ -191,29 +191,52 @@ USA.
 \f
 ;;;; Merging
 
-(define (merge-uris uri base-uri)
-  (let ((uri (->uri uri 'MERGE-URIS))
-       (base-uri (->absolute-uri base-uri 'MERGE-URIS)))
-    (cond ((uri-scheme uri)
-          uri)
-         ((uri-authority uri)
-          (make-uri (uri-scheme base-uri)
-                    (uri-authority uri)
-                    (uri-path uri)
-                    (uri-query uri)
-                    (uri-fragment uri)))
-         ((null? (uri-path uri))
-          (make-uri (uri-scheme base-uri)
-                    (uri-authority base-uri)
-                    (uri-path base-uri)
-                    (or (uri-query uri) (uri-query base-uri))
-                    (uri-fragment uri)))
-         (else
-          (make-uri (uri-scheme base-uri)
-                    (uri-authority base-uri)
-                    (merge-paths (uri-path uri) base-uri)
-                    (uri-query uri)
-                    (uri-fragment uri))))))
+(define (merge-uris uri #!optional base-uri)
+  (%merge-uris (->uri uri 'MERGE-URIS)
+              (compute-base-uri base-uri 'MERGE-URIS)))
+
+(define (compute-base-uri base-uri caller)
+  (let ((default (param:base-uri)))
+    (if default
+       (if (default-object? base-uri)
+           default
+           (let ((base-uri (->uri base-uri caller)))
+             (if (uri-relative? base-uri)
+                 (%merge-uris base-uri default)
+                 base-uri)))
+       (begin
+         (if (default-object? base-uri)
+             (error "Must supply a base URI for merging:" caller))
+         (->absolute-uri base-uri caller)))))
+
+(define param:base-uri)
+(define (make-param:base-uri)
+  (make-parameter #f
+                 (lambda (object)
+                   (and object
+                        (->absolute-uri object 'param:base-uri)))))
+
+(define (%merge-uris uri base-uri)
+  (cond ((uri-scheme uri)
+        uri)
+       ((uri-authority uri)
+        (make-uri (uri-scheme base-uri)
+                  (uri-authority uri)
+                  (uri-path uri)
+                  (uri-query uri)
+                  (uri-fragment uri)))
+       ((null? (uri-path uri))
+        (make-uri (uri-scheme base-uri)
+                  (uri-authority base-uri)
+                  (uri-path base-uri)
+                  (or (uri-query uri) (uri-query base-uri))
+                  (uri-fragment uri)))
+       (else
+        (make-uri (uri-scheme base-uri)
+                  (uri-authority base-uri)
+                  (merge-paths (uri-path uri) base-uri)
+                  (uri-query uri)
+                  (uri-fragment uri)))))
 
 (define (merge-paths ref-path base-uri)
   (cond ((path-absolute? ref-path)
@@ -906,6 +929,8 @@ USA.
   (set! url:char-set:unescaped
        (char-set-union url:char-set:unreserved
                        (string->char-set ";/?:@&=")))
+
+  (set! param:base-uri (make-param:base-uri))
   unspecific)
 \f
 ;;;; Partial URIs