3 * Stefano Zacchiroli <zack@cs.unibo.it>
4 * for the HELM Team http://helm.cs.unibo.it/
6 * This file is part of HELM, an Hypertextual, Electronic
7 * Library of Mathematics, developed at the Computer Science
8 * Department, University of Bologna, Italy.
10 * HELM is free software; you can redistribute it and/or
11 * modify it under the terms of the GNU General Public License
12 * as published by the Free Software Foundation; either version 2
13 * of the License, or (at your option) any later version.
15 * HELM is distributed in the hope that it will be useful,
16 * but WITHOUT ANY WARRANTY; without even the implied warranty of
17 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 * GNU General Public License for more details.
20 * You should have received a copy of the GNU General Public License
21 * along with HELM; if not, write to the Free Software
22 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
25 * For details, see the HELM World-Wide-Web page,
26 * http://helm.cs.unibo.it/
32 (** set this to true and uwobo will save transformation's intermediate results
33 in /tmp/uwobo_intermediate_<seqno>_<pid>.xml *)
34 let save_intermediate_results = false;;
36 exception Unsupported_property of string;;
38 let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
39 let outputS = Gdome.domString "output"
40 let q_outputS = Gdome.domString "xsl:output"
42 let default_properties = [] (* no default properties *)
44 (** apply an output property to an xslt stylesheet *)
45 let apply_property logger (element: Gdome.element) (name, value) =
46 if Uwobo_common.is_supported_property name then begin
47 logger#log `Debug (sprintf "Setting property: %s = %s" name value);
48 element#setAttribute (Gdome.domString name) (Gdome.domString value)
50 raise (Unsupported_property name)
52 (** set a list of output properties in an xslt stylesheet, return a copy of
53 the given stylesheet modified as needed, given stylesheet wont be changed by
55 Before applying "props" properties applies a set of default properties as
56 defined in "default_properties" *)
57 let apply_properties logger last_stylesheet props =
59 new Gdome.document_of_node (last_stylesheet#cloneNode ~deep:true)
62 let node_list = last_stylesheet#getElementsByTagNameNS xslNS outputS in
63 (match node_list#item 0 with
64 | None -> (* no xsl:output element, create it from scratch *)
65 logger#log `Debug "Creating xsl:output node ...";
66 let elt = last_stylesheet#createElementNS (Some xslNS) q_outputS in
67 let root = last_stylesheet#get_documentElement in
68 ignore (root#appendChild (elt :> Gdome.node));
70 | Some node -> new Gdome.element_of_node node)
73 (apply_property logger (output_element :> Gdome.element))
74 (default_properties @ props);
77 (** given a Gdome.document representing an XSLT stylesheet and an output
78 property return 'Some value' where 'value' is the property value, or None if
80 let get_property name (document: Gdome.document) =
81 let node_list = document#getElementsByTagNameNS xslNS outputS in
82 match node_list#item 0 with
85 let element = new Gdome.element_of_node node in
86 let domName = Gdome.domString name in
87 if element#hasAttribute domName then
88 Some (element#getAttribute domName)#to_string
93 let namespaceURI = Some (Gdome.domString Uwobo_common.uwobo_namespace) ;;
95 (** output type wrt adding of debugging/error messages *)
97 | XmlOutput of Gdome.node
98 | TextPlainOutput of Gdome.text
102 exception Found of int ;;
104 (** add debugging and/or error messages to a Gdome document. Handle three
105 distinct cases: (1) output contains an XML tree, (2) output contains only one
106 text node, (3) output contains no data.
107 If output contains an XML tree then users wishes are preserved and messages
108 are either not included or included as comments or included as XML ndoes.
109 If output contains only a text node comments are either not included or
110 included at the beginning of the textual output.
111 If output contains no data (i.e. DOM superroot node with no element or text
112 children) messages are embedded as XML comments or not embedded at all *)
113 let add_msgs ~errormode ~debugmode ~msgs (doc: Gdome.document) =
114 let getOutputType (doc: Gdome.document) =
115 let children = doc#get_childNodes in
116 let len = children#get_length in
117 let rec find_element i =
121 (match children#item i with
122 | Some node when node#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE ->
124 | _ -> find_element (i + 1))
126 let rec find_text i =
130 (match children#item i with
131 | Some node when node#get_nodeType = GdomeNodeTypeT.TEXT_NODE ->
132 TextPlainOutput (new Gdome.text_of_node node)
133 | _ -> find_element (i + 1))
138 (try find_element 0 with Not_found ->
139 (try find_text 0 with Not_found -> NoOutput))
141 match getOutputType (doc :> Gdome.document) with
143 let add_generic_msg mode build tagname =
145 | LibXsltMsgIgnore -> (fun msg -> ())
146 | LibXsltMsgComment ->
148 (* let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
149 let contents = string_of_xslt_msg (build msg) in
150 ignore (node#insertBefore
151 ~newChild:(doc#createComment
152 (Gdome.domString contents) :> Gdome.node)
153 ~refChild:node#get_firstChild))
156 (* let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
157 let contents = string_of_xslt_msg (build msg) in
160 ~namespaceURI ~qualifiedName:(Gdome.domString tagname)
162 ignore (element#appendChild
164 ~data:(Gdome.domString contents) :> Gdome.node));
165 ignore (node#insertBefore
166 ~newChild:(element :> Gdome.node)
167 ~refChild:node#get_firstChild)))
171 errormode (fun msg -> LibXsltErrorMsg msg) "uwobo:error"
175 debugmode (fun msg -> LibXsltDebugMsg msg) "uwobo:debug"
179 | LibXsltErrorMsg msg -> add_error_msg msg
180 | LibXsltDebugMsg msg -> add_debug_msg msg)
181 (List.rev msgs) (* because each msg is added as 1st children *)
182 | TextPlainOutput text ->
183 let add_generic_msg mode build =
185 | LibXsltMsgIgnore -> (fun _ -> ())
186 | LibXsltMsgComment | LibXsltMsgEmbed ->
188 text#insertData ~offset:0
189 ~arg:(Gdome.domString
190 (string_of_xslt_msg (build msg) ^ "\n"))))
193 add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
196 add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
200 | LibXsltErrorMsg msg -> add_error_msg msg
201 | LibXsltDebugMsg msg -> add_debug_msg msg)
202 (List.rev msgs) (* because each msg is added as 1st children *)
204 let add_generic_msg mode build =
206 | LibXsltMsgIgnore -> (fun _ -> ())
207 | LibXsltMsgComment | LibXsltMsgEmbed ->
210 (* use comments anyway because text nodes aren't allowed in DOM as
211 superroot children *)
213 (Gdome.domString (string_of_xslt_msg (build msg)))
215 ignore (doc#insertBefore ~newChild:(comment_node :> Gdome.node)
216 ~refChild:doc#get_firstChild)))
219 add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
222 add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
226 | LibXsltErrorMsg msg -> add_error_msg msg
227 | LibXsltDebugMsg msg -> add_debug_msg msg)
228 (List.rev msgs) (* because each msg is added as 1st children *)
232 ~(logger: Uwobo_logger.sysLogger)
233 ~(styles: Uwobo_styles.styles)
235 ~(veillogger: Uwobo_common.libXsltLogger)
236 ?(errormode = LibXsltMsgIgnore) ?(debugmode = LibXsltMsgIgnore)
239 (* "p_" prefix means "processed" *)
240 let (p_stylesheets, last_stylesheet) = styles#get keys in
241 logger#log `Debug "Creating input document ...";
242 let intermediate_results_seqno = ref 0 in
243 let result = (* Gdome.document *)
245 (fun source (key, stylesheet) ->
246 logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
249 List.map (fun (key,value) -> (key, "'" ^ value ^ "'")) (params key)
252 (sprintf "Gdome_xslt.applyStylesheet params=%s"
253 (String.concat ", " (List.map (fun (k,v) -> k^": "^v) params)));
254 let res = Gdome_xslt.applyStylesheet ~source ~stylesheet ~params in
255 if save_intermediate_results then begin
256 let domImpl = Gdome.domImplementation () in
258 (domImpl#saveDocumentToFile
260 ~name:(sprintf "/tmp/uwobo_intermediate_%d_%d.xml"
261 !intermediate_results_seqno (Unix.getpid()))
263 incr intermediate_results_seqno;
266 with e -> raise (Uwobo_failure (Printexc.to_string e)))
270 (* add error and debugging messages to result document *)
271 add_msgs ~errormode ~debugmode ~msgs:veillogger#msgs result;
275 ~errormode:LibXsltMsgEmbed ~debugmode:LibXsltMsgEmbed
276 ~msgs:[LibXsltErrorMsg "error1"; LibXsltDebugMsg "debug1"]
279 let last_stylesheet = (* used to retrieve serialization options *)
281 apply_properties logger last_stylesheet props
282 with Unsupported_property prop ->
283 raise (Uwobo_failure (sprintf "Unsupported property: %s" prop))
285 let p_last_stylesheet = Gdome_xslt.processStylesheet last_stylesheet in
286 ((fun outchan -> (* serialization function *)
287 Gdome_xslt.saveResultToChannel ~outchan ~result
288 ~stylesheet:p_last_stylesheet),
289 (get_property "media-type" last_stylesheet), (* media-type *)
290 (get_property "encoding" last_stylesheet)) (* encoding *)