]> matita.cs.unibo.it Git - helm.git/blob - helm/uwobo/uwobo_engine.ml
tex notation for compatibility with texTermEditor
[helm.git] / helm / uwobo / uwobo_engine.ml
1 (*
2  * Copyright (C) 2003:
3  *    Stefano Zacchiroli <zack@cs.unibo.it>
4  *    for the HELM Team http://helm.cs.unibo.it/
5  *
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.
9  *
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.
14  *
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.
19  *
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,
23  *  MA  02111-1307, USA.
24  *
25  *  For details, see the HELM World-Wide-Web page,
26  *  http://helm.cs.unibo.it/
27  *)
28
29 open Printf;;
30 open Uwobo_common;;
31
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;;
35
36 let xslNS = Gdome.domString "http://www.w3.org/1999/XSL/Transform"
37 let outputS = Gdome.domString "output"
38
39   (** given a Gdome.document representing an XSLT stylesheet and an output
40   property return 'Some value' where 'value' is the property value, or None if
41   it's not defined *)
42 let get_property name (document: Gdome.document) =
43   let node_list = document#getElementsByTagNameNS xslNS outputS in
44   match node_list#item 0 with
45   | None -> None
46   | Some node ->
47       let element = new Gdome.element_of_node node in
48       let domName = Gdome.domString name in
49       if element#hasAttribute domName then
50         Some (element#getAttribute domName)#to_string
51       else
52         None
53 ;;
54
55 let namespaceURI = Some (Gdome.domString Uwobo_common.uwobo_namespace) ;;
56
57   (** output type wrt adding of debugging/error messages *)
58 type outputType =
59   | XmlOutput of Gdome.node
60   | TextPlainOutput of Gdome.text
61   | NoOutput
62 ;;
63
64 exception Found of int ;;
65
66   (** add debugging and/or error messages to a Gdome document. Handle three
67   distinct cases: (1) output contains an XML tree, (2) output contains only one
68   text node, (3) output contains no data.
69   If output contains an XML tree then users wishes are preserved and messages
70   are either not included or included as comments or included as XML ndoes.
71   If output contains only a text node comments are either not included or
72   included at the beginning of the textual output.
73   If output contains no data (i.e. DOM superroot node with no element or text
74   children) messages are embedded as XML comments or not embedded at all *)
75 let add_msgs ~errormode ~debugmode ~msgs (doc: Gdome.document) =
76   let getOutputType (doc: Gdome.document) =
77     let children = doc#get_childNodes in
78     let len = children#get_length in
79     let rec find_element i =
80       if i > len then
81         raise Not_found
82       else
83         (match children#item i with
84         | Some node when node#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE ->
85             XmlOutput node
86         | _ -> find_element (i + 1))
87     in
88     let rec find_text i =
89       if i > len then
90         raise Not_found
91       else
92         (match children#item i with
93         | Some node when node#get_nodeType = GdomeNodeTypeT.TEXT_NODE ->
94             TextPlainOutput (new Gdome.text_of_node node)
95         | _ -> find_element (i + 1))
96     in
97     if len = 0 then
98       NoOutput
99     else
100       (try find_element 0 with Not_found ->
101         (try find_text 0 with Not_found -> NoOutput))
102   in
103   match getOutputType (doc :> Gdome.document) with
104   | XmlOutput node ->
105     let add_generic_msg mode build tagname =
106       (match mode with
107       | LibXsltMsgIgnore -> (fun msg -> ())
108       | LibXsltMsgComment ->
109           (fun msg ->
110 (*                 let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
111             let contents = string_of_xslt_msg (build msg) in
112             ignore (node#insertBefore
113               ~newChild:(doc#createComment
114                 (Gdome.domString contents) :> Gdome.node)
115               ~refChild:node#get_firstChild))
116       | LibXsltMsgEmbed ->
117           (fun msg ->
118 (*                 let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
119             let contents = string_of_xslt_msg (build msg) in
120             let element =
121               doc#createElementNS
122                 ~namespaceURI ~qualifiedName:(Gdome.domString tagname)
123             in
124             ignore (element#appendChild
125               (doc#createTextNode
126                 ~data:(Gdome.domString contents) :> Gdome.node));
127             ignore (node#insertBefore
128               ~newChild:(element :> Gdome.node)
129               ~refChild:node#get_firstChild)))
130     in
131     let add_error_msg =
132       add_generic_msg
133         errormode (fun msg -> LibXsltErrorMsg msg) "uwobo:error"
134     in
135     let add_debug_msg =
136       add_generic_msg
137         debugmode (fun msg -> LibXsltDebugMsg msg) "uwobo:debug"
138     in
139     List.iter
140       (function
141         | LibXsltErrorMsg msg -> add_error_msg msg
142         | LibXsltDebugMsg msg -> add_debug_msg msg)
143       (List.rev msgs) (* because each msg is added as 1st children *)
144 | TextPlainOutput text ->
145     let add_generic_msg mode build =
146       (match mode with
147       | LibXsltMsgIgnore -> (fun _ -> ())
148       | LibXsltMsgComment | LibXsltMsgEmbed ->
149           (fun msg ->
150             text#insertData ~offset:0
151               ~arg:(Gdome.domString
152                 (string_of_xslt_msg (build msg) ^ "\n"))))
153     in
154     let add_error_msg =
155       add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
156     in
157     let add_debug_msg =
158       add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
159     in
160     List.iter
161       (function
162         | LibXsltErrorMsg msg -> add_error_msg msg
163         | LibXsltDebugMsg msg -> add_debug_msg msg)
164       (List.rev msgs) (* because each msg is added as 1st children *)
165 | NoOutput ->
166     let add_generic_msg mode build =
167       (match mode with
168       | LibXsltMsgIgnore -> (fun _ -> ())
169       | LibXsltMsgComment | LibXsltMsgEmbed ->
170           (fun msg ->
171             let comment_node =
172               (* use comments anyway because text nodes aren't allowed in DOM as
173               superroot children *)
174               doc#createComment
175                 (Gdome.domString (string_of_xslt_msg (build msg)))
176             in
177             ignore (doc#insertBefore ~newChild:(comment_node :> Gdome.node)
178               ~refChild:doc#get_firstChild)))
179     in
180     let add_error_msg =
181       add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
182     in
183     let add_debug_msg =
184       add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
185     in
186     List.iter
187       (function
188         | LibXsltErrorMsg msg -> add_error_msg msg
189         | LibXsltDebugMsg msg -> add_debug_msg msg)
190       (List.rev msgs) (* because each msg is added as 1st children *)
191 ;;
192
193 let apply
194   ~(logger: Uwobo_logger.sysLogger)
195   ~(styles: Uwobo_styles.styles)
196   ~keys ~params ~props
197   ~(veillogger: Uwobo_common.libXsltLogger)
198   ?(errormode = LibXsltMsgIgnore) ?(debugmode = LibXsltMsgIgnore)
199   input
200   =
201     (* "p_" prefix means "processed" *)
202   let (p_stylesheets,last_stylesheet) = styles#get keys props logger in
203   logger#log `Debug "Creating input document ...";
204   let intermediate_results_seqno = ref 0 in
205   let result = (* Gdome.document *)
206     List.fold_left
207       (fun source (key, stylesheet) ->
208         logger#log `Debug (sprintf "Applying stylesheet %s ..." key);
209         try
210           let params =
211             List.map
212              (fun (key,value) ->
213                let quoted_value =
214                 if String.contains value '\'' then
215                  if String.contains value '"' then
216                   raise
217                    (Failure
218                      ("A parameter value can not contain both single and " ^
219                       "double quotes, since it must be a valid XPath string " ^
220                       "literal"))
221                  else
222                   "\"" ^ value ^ "\""
223                 else
224                  "'" ^ value ^ "'"
225                in
226                 (key,quoted_value)
227              ) (params key)
228           in
229           logger#log `Debug
230             (sprintf "Gdome_xslt.applyStylesheet params=%s"
231               (String.concat ", " (List.map (fun (k,v) -> k^": "^v) params)));
232           let res = Gdome_xslt.applyStylesheet ~source ~stylesheet ~params in
233           if save_intermediate_results then begin
234             let domImpl = Gdome.domImplementation () in
235             ignore
236               (domImpl#saveDocumentToFile
237                 ~doc:res
238                 ~name:(sprintf "/tmp/uwobo_intermediate_%d_%d.xml"
239                   !intermediate_results_seqno (Unix.getpid()))
240                 ());
241             incr intermediate_results_seqno;
242           end;
243           res
244         with e -> raise (Uwobo_failure (Printexc.to_string e)))
245       input
246       p_stylesheets
247   in
248     (* add error and debugging messages to result document *)
249   add_msgs ~errormode ~debugmode ~msgs:veillogger#msgs result;
250 (*
251   (* DEBUGGING *)
252   add_msgs
253     ~errormode:LibXsltMsgEmbed ~debugmode:LibXsltMsgEmbed
254     ~msgs:[LibXsltErrorMsg "error1"; LibXsltDebugMsg "debug1"]
255     result;
256 *)
257   let p_last_stylesheet = snd (List.hd (List.rev p_stylesheets)) in
258   ((fun outchan ->                              (* serialization function *)
259       Gdome_xslt.saveResultToChannel ~outchan ~result
260         ~stylesheet:p_last_stylesheet),
261    (get_property "media-type" last_stylesheet), (* media-type *)
262    (get_property "encoding" last_stylesheet))   (* encoding *)
263