Initial revision

[helm.git] / helm / uwobo / src / ocaml / uwobo_engine.ml

diff --git a/helm/uwobo/src/ocaml/uwobo_engine.ml b/helm/uwobo/src/ocaml/uwobo_engine.ml
index bda9b1804e9a7f1ba550d0ca23649d61b6a193c5..75e4669bf0d0ac251bd0d959c0cc8dc2930e7890 100644 (file)
--- a/helm/uwobo/src/ocaml/uwobo_engine.ml
+++ b/helm/uwobo/src/ocaml/uwobo_engine.ml
@@ -27,48 +27,97 @@
 open Printf;;
 open Uwobo_common;;
 
-let dump_args keys params props =
-  (sprintf "
-Keys: %s<br />
-Parameters:<br />
-%s
-Props: %s<br />
-"
-    (String.concat ", " keys)
-    (String.concat
-      "<br />\n"
-      (List.map
-        (fun key ->
-          (sprintf
-            "Key: %s, Params: %s"
-            key
-            (String.concat
-              ", "
-              (List.map
-                (fun (key,value) -> sprintf "%s:%s" key value)
-                (params key)))))
-        keys))
-    (String.concat
-      ", "
-      (List.map (fun (key,value) -> sprintf "%s:%s" key value) props)))
+exception Unsupported_property of string;;
+
+let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
+let outputS = Gdome.domString "output"
+let q_outputS = Gdome.domString "xsl:output"
+
+  (** set a list of output properties in an xslt stylesheet, return a copy of
+  the given stylesheet modified as needed, given stylesheet wont be changed by
+  this operation *)
+let apply_properties logger last_stylesheet props =
+  let last_stylesheet =
+    new Gdome.document_of_node (last_stylesheet#cloneNode ~deep:true)
+  in
+  let output_element =
+    let node_list = last_stylesheet#getElementsByTagNameNS xslNS outputS in
+    (match node_list#item 0 with
+    | None -> (* no xsl:output element, create it from scratch *)
+        logger#log `Debug "Creating xsl:output node ...";
+        let elt = last_stylesheet#createElementNS (Some xslNS) q_outputS in
+        let root = last_stylesheet#get_documentElement in
+        ignore (root#appendChild (elt :> Gdome.node));
+        elt
+    | Some node -> new Gdome.element_of_node node)
+  in
+  let apply_property (name, value) =
+    if Uwobo_common.is_supported_property name then begin
+        logger#log `Debug (sprintf "Setting property: %s = %s" name value);
+        output_element#setAttribute
+          (Gdome.domString name)
+          (Gdome.domString value)
+      end
+    else
+      raise (Unsupported_property name)
+  in
+  List.iter apply_property props;
+  last_stylesheet
+
+  (** given a Gdome.document representing an XSLT stylesheet and an output
+  property return 'Some value' where 'value' is the property value, or None if
+  it's not defined *)
+let get_property name (document: Gdome.document) =
+  let node_list = document#getElementsByTagNameNS xslNS outputS in
+  match node_list#item 0 with
+  | None -> None
+  | Some node ->
+      let element = new Gdome.element_of_node node in
+      let domName = Gdome.domString name in
+      if element#hasAttribute domName then
+        Some (element#getAttribute domName)#to_string
+      else
+        None
 
-  (* TODO add global mutex, stylesheets are freezed at the request moment *)
 let apply
   ~(logger: Uwobo_logger.sysLogger)
   ~(styles: Uwobo_styles.styles)
   ~keys ~params ~props ~input =
-  let stylesheets = styles#get keys in
-  logger#log `Debug (dump_args keys params props);
+    (* "p_" prefix means "processed" *)
+  let (p_stylesheets, last_stylesheet) = styles#get keys in
   logger#log `Debug "Creating input document ...";
-  List.fold_left
-    (fun source (key, stylesheet) ->
-      logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
-      try
-        let params =
-          List.map (fun (key,value) -> (key, "'" ^ value ^ "'")) (params key)
-        in
-        Gdome_xslt.applyStylesheet ~source ~stylesheet ~params
-      with e -> raise (Uwobo_failure (Printexc.to_string e)))
-    input
-    stylesheets
+  let result = (* Gdome.document *)
+    List.fold_left
+      (fun source (key, stylesheet) ->
+        logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
+        try
+          let params =
+            List.map (fun (key,value) -> (key, "'" ^ value ^ "'")) (params key)
+          in
+          logger#log
+            `Debug
+            (sprintf
+              "Gdome_xslt.applyStylesheet params=%s"
+              (String.concat ", " (List.map (fun (k,v) -> k^": "^v) params)));
+          let res = Gdome_xslt.applyStylesheet ~source ~stylesheet ~params in
+          res
+        with e -> raise (Uwobo_failure (Printexc.to_string e)))
+      input
+      p_stylesheets
+  in
+    (* used to retrieve serialization options *)
+  let last_stylesheet =
+    try
+      apply_properties logger last_stylesheet props
+    with Unsupported_property prop ->
+      raise (Uwobo_failure (sprintf "Unsupported property: %s" prop))
+  in
+  let p_last_stylesheet = Gdome_xslt.processStylesheet last_stylesheet in
+  ((fun outchan ->                              (* serialization function *)
+      Gdome_xslt.saveResultToChannel
+        ~outchan
+        ~result
+        ~stylesheet:p_last_stylesheet),
+   (get_property "media-type" last_stylesheet), (* media-type *)
+   (get_property "encoding" last_stylesheet))   (* encoding *)