From bd59745a232bff0e941e97170b88709d0ff6fdf2 Mon Sep 17 00:00:00 2001
From: Stefano Zacchiroli <zack@upsilon.cc>
Date: Mon, 17 May 2004 17:48:33 +0000
Subject: [PATCH] Added support for xml base(s) URL and URI. The getter now
 adds these two attributes (hopefully) on the first open tag

---
 helm/ocaml/getter/http_getter_cache.ml   |  5 ++++-
 helm/ocaml/getter/http_getter_common.ml  | 21 +++++++++++++++++++--
 helm/ocaml/getter/http_getter_common.mli |  4 +++-
 3 files changed, 26 insertions(+), 4 deletions(-)

diff --git a/helm/ocaml/getter/http_getter_cache.ml b/helm/ocaml/getter/http_getter_cache.ml
index 3eebf4b3f..ef0a8dffa 100644
--- a/helm/ocaml/getter/http_getter_cache.ml
+++ b/helm/ocaml/getter/http_getter_cache.ml
@@ -101,7 +101,10 @@ let respond_xml
           (Lazy.force Http_getter_env.rdf_dir) escaped_prefix baseuri extension
   in
   let patch_fun =
-    if patch then Http_getter_common.patch_xml ~via_http () else (fun x -> x)
+    if patch then
+      Http_getter_common.patch_xml ~xmlbases:(uri, url) ~via_http ()
+    else
+      (fun x -> x)
   in
   let basename = Pcre.replace ~pat:"\\.gz$" downloadname in
   let contype = "text/xml" in
diff --git a/helm/ocaml/getter/http_getter_common.ml b/helm/ocaml/getter/http_getter_common.ml
index 03f5c2a2a..a4ca3bf1c 100644
--- a/helm/ocaml/getter/http_getter_common.ml
+++ b/helm/ocaml/getter/http_getter_common.ml
@@ -90,9 +90,26 @@ let patch_system kind ?(via_http = true) () =
 let patch_entity = patch_system "ENTITY"
 let patch_doctype = patch_system "DOCTYPE"
 
+let patch_xmlbase =
+  let rex = Pcre.regexp "^(\\s*<\\w[^ ]*)(\\s|>)" in
+  fun xmlbases baseurl baseuri s ->
+    let s' =
+      Pcre.replace ~rex
+        ~templ:(sprintf "$1 xml:base=\"%s\" helm:base=\"%s\"$2" baseurl baseuri)
+        s
+    in
+    if s <> s' then xmlbases := None;
+    s'
+
 let patch_dtd = patch_entity
-let patch_xml ?via_http () line =
-  patch_doctype ?via_http () (patch_entity ?via_http () line)
+let patch_xml ?via_http ?xmlbases () =
+  let xmlbases = ref xmlbases in
+  fun line ->
+    match !xmlbases with
+    | None -> patch_doctype ?via_http () (patch_entity ?via_http () line)
+    | Some (xmlbaseuri, xmlbaseurl) ->
+        patch_xmlbase xmlbases xmlbaseurl xmlbaseuri
+          (patch_doctype ?via_http () (patch_entity ?via_http () line))
 
 let return_file
   ~fname ?contype ?contenc
diff --git a/helm/ocaml/getter/http_getter_common.mli b/helm/ocaml/getter/http_getter_common.mli
index b4f733d8f..f626f4ab0 100644
--- a/helm/ocaml/getter/http_getter_common.mli
+++ b/helm/ocaml/getter/http_getter_common.mli
@@ -38,7 +38,9 @@ val is_xsl_uri: string -> bool
 
 val uri_of_string: string -> uri
 
-val patch_xml : ?via_http:bool -> unit -> string -> string
+  (** @param xmlbases (xml base URI * xml base URL) *)
+val patch_xml :
+  ?via_http:bool -> ?xmlbases:(string * string) -> unit -> string -> string
 val patch_dtd : ?via_http:bool -> unit -> string -> string
   (* TODO via_http not yet supported for patch_xsl *)
 val patch_xsl : ?via_http:bool -> unit -> string -> string
-- 
2.39.2