open Printf;;
open Uwobo_common;;
+exception Unsupported_property of string;;
+
+let supported_properties = [
+ "cdata-section-elements";
+ "doctype-public";
+ "doctype-system";
+ "encoding";
+ "indent";
+ "media-type";
+ "method";
+ "omit-xml-declaration";
+ "standalone";
+ "version"
+]
+
let dump_args keys params props =
(sprintf "
Keys: %s<br />
", "
(List.map (fun (key,value) -> sprintf "%s:%s" key value) props)))
- (* TODO add global mutex, stylesheets are freezed at the request moment *)
+let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
+let outputS = Gdome.domString "output"
+let q_outputS = Gdome.domString "xsl:output"
+let is_supported_property name = List.mem name supported_properties
+
+ (** 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 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
+
let apply
~(logger: Uwobo_logger.sysLogger)
~(styles: Uwobo_styles.styles)
~keys ~params ~props ~input =
- let stylesheets = styles#get keys in
+ (* "p_" prefix means "processed" *)
+ let (p_stylesheets, last_stylesheet) = styles#get keys in
logger#log `Debug (dump_args keys params props);
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 *)